--- /dev/null
+# Speare
+ <br>
+The ultra lightweight code editor and small IDE.<br>
+http://sevenuc.com/en/Speare.html<br>
+http://github.com/chengdu/Speare<br>
+https://sourceforge.net/projects/speare/<br>
+
+Speare is an ultra lightweight code editor and a small IDE that provides debugging environment for C, C++, Ruby, mruby, Lua, Python, PHP, Perl and Tcl. It was originally developed to providing a native scripting language debugging environment that seamlessly integrated with C and C++, and with an efficient code navigation and call routines tracing ability. Speare has very simple interface that allows end user to add a new programming language code runner, parser, syntax highlighting, code formatter and debugger to it. Most of the debuggers of Speare code editor supports extending themselves in source code level and directly switch between any version of self-compiled scripting language interpreters.<br>
+
+Why another code editor and IDE on macOS?
+------------
+Although there are so many code editor and IDE available on macOS, but three feature of Speare code editor can make it unique:<br>
+1. **Lightweight.** Most of them are very heavy, bulky, but Speare code editor is really really ultra light.<br>
+2. **Cost.** Most of them are very expensive, but Speare code editor is free, of course, you can purchase the pro version to donate some money to the author, but that is not mandatory.<br>
+3. **Freedom.** Feel light, simple and free, flexibility to extend the IDE to support special developing requirements and easily add a new programming language to it, most of the IDE on macOS can't give you such ability and freedom. In fact, Speare code editor give you very flexible control to extend it and add a debugging environment for any programming language.<br>
+
+Features
+------------
+1. Well designed user operation interface. Intuitive and simple.<br>
+2. High performance of managing large amount of files and big files.<br>
+3. Fast search and replace in current document, selected folder, opened files and entire project.<br>
+4. Smoothly edit multiple files that written in different programming languages simultaneously.<br>
+5. Supports almost all common programming languages syntax highlighting and parsing.<br>
+6. Auto-completion, sensitively typing with keywords, live parsing symbol definition with priority.<br>
+7. Jump to definition and fast locate code lines between editing files by symbol index, bookmark or searching.<br>
+8. Unlimited go back and forward, automatically remember jump location and current editing locations.<br>
+9. Keeping entire state after quit, the opened files, selection of each file and the cursor location.<br>
+10. Customisation of fonts and colours for the text editor.<br>
+11. Full featured markdown editor, run Javascript code instantly, well support Web development.<br>
+12. Ultra lightweight.<br>
+<br>
+
+
+Other Builtin Features:
+------------
+a. Run syntax checking and editing code instantly.<br>
+b. C and C++ debugging with LLDB.<br>
+c. Binary file automatically detection.<br>
+d. Automatically detecting file encoding and convert to UTF-8 by default when open file.<br>
+e. Code block selection by double clicking the begin symbol of code block.<br>
+f. Preview all kinds of files, image, pdf, office documents, audio and video etc.<br>
+<br>
+
+Screenshots
+-------------
+ <br>
+ <br>
+ <br>
+ <br>
+<br>
+
+C and C++ Debugger
+-----------
+The [C and C++ debugger](http://sevenuc.com/en/debugger.html#lldb) of Speare implemented as a script client of [LLDB](http://lldb.llvm.org/), and support extend it by yourself. You can enjoy debugging almost any type of C and C++ applications under the lightweight debugging environment of Speare code editor.<br>
+<br>
+
+mruby Debugger
+-----------
+The [mruby debugger](http://sevenuc.com/en/debugger.html#mruby) of Speare Pro is a patched version of mruby 2.0.1 that support remote debugging mruby project.<br>
+<br>
+
+Ruby Debugger
+-----------
+The [Ruby debugger](http://sevenuc.com/en/debugger.html#ruby) of Speare Pro support all kinds of Ruby interpreters, the version includes: 1.8.x, 1.9.x, 2.x, and JRuby. of course, Rails debugging also supported.<br>
+<br>
+
+Lua Debugger
+-----------
+The [Lua debugger](http://sevenuc.com/en/debugger.html#lua) of Speare Pro support Lua debugging version includes: 5.1.4, 5.1.5, 5.2.4, 5.3.5 5.4.0-alpha, all kinds of Lua interpreter or your own customised version of Lua.<br>
+<br>
+
+Python Debugger
+-----------
+The [Python debugger](http://sevenuc.com/en/debugger.html#python) of Speare Pro supports Python version 2.5, 2.6, 2.7 and 3.x, and MicroPython. Debugging framework such as Flask and Django based on application also supported.<br>
+<br>
+
+PHP Debugger
+-----------
+The [PHP debugger](http://sevenuc.com/en/debugger.html#php) of Speare Pro supports all kinds debugging of PHP applications and any version of PHP interpreter that has Xdebug support from PHP 5.x to PHP 7.x. Debugging PHP command line applications is as same as web applications that based on web frameworks.<br>
+<br>
+
+Perl Debugger
+-----------
+The [Perl debugger](http://sevenuc.com/en/debugger.html#perl) of Speare Pro implemented as a patched version of perl5db.pl, and support extend it by yourself. The debugger was based on the builtin debugger of Perl, so it can work with all versions of Perl interpreter that perl5db.pl supported.<br>
+<br>
+
+Tcl Debugger
+-----------
+The [Tcl debugger](http://sevenuc.com/en/debugger.html#tcl) of Speare code editor implemented with Tcl scripts and an extension written with C to parse Tcl source code, and support extend it by yourself. You can enjoy debugging almost all kinds of Tcl applications under the lightweight debugging environment of Speare code editor.<br>
+<br>
+
+Add a New Programming Language
+-----------
+Download the guide from here: [Language Extension Protocol](http://sevenuc.com/download/language_extension_protocol.pdf), and following the description to add a new programming language code runner, parser, syntax highlighting, code formatter and debugger in Speare code editor.<br>
+<br>
+
+References
+-------------
+Speare code editor: http://sevenuc.com/en/Speare.html<br>
+Speare Pro, the ultra lightweight IDE: http://sevenuc.com/en/debugger.html<br>
--- /dev/null
+Speare Debug Server v0.0.2
+Copyright (c) 2019 sevenuc.com. All rights reserved.
+
+This is the Tcl debugger for Speare code editor:
+http://sevenuc.com/en/Speare.html
+
+Package source and download:
+https://github.com/chengdu/Speare
+https://sourceforge.net/projects/speare
+http://sevenuc.com/download/tcl_debugger.tar.gz
+
+Package Content:
+
+TclDebugger
+|-- readme.txt # this file, readme for this package
+|-- src # the source code of the Tcl debugger
+| |-- appLaunch.tcl
+| |-- block.tcl
+| |-- break.tcl
+| |-- dbg.tcl
+| |-- debugger.tcl
+| |-- instrument.tcl
+| |-- location.tcl
+| |-- nub.tcl
+| `-- util.tcl
+|-- tclparser.tar.gz # the source code of the Tcl parser library
+
+
+Start Debug Server:
+
+0. Compile Tcl interpreter from source:
+ Download Tcl from https://sourceforge.net/projects/tcl,
+ please select a suitable Tcl version for your project.
+
+ $ tar -zxvf tcl8.5.9-src.tar.gz
+ $ cd tcl8.5.9/unix
+ $ ./configure --prefix=/Users/yeung/bin/tcl \
+ --enable-threads --enable-64bit \
+ --enable-corefoundation
+ $ make && make install
+ $ export PATH=/Users/yeung/bin/tcl/bin:$PATH
+
+ Compile Tcl parser library used by the debugger
+ $ tar -zxvf tclparser.tar.gz
+ $ cd tclparser
+ $ ./configure --prefix=/Users/yeung/bin/tcl/bin \
+ --enable-threads --enable-64bit \
+ --with-tcl=/Users/yeung/bin/tcl/lib/
+ $ make && make install
+ After above steps, it should create a file named
+ libtclparser1.8.dylib and put under tclparser1.8
+
+
+1. Configure the debugger
+ The configure options of the debugger was directly written
+ in the source code of the debugger, located in
+ TclDebugger/src/debugger.tcl.
+
+ # The inner port used by the debugger
+ set port 2576
+
+ # The communication port between the debugger and Speare code editor
+ set svcPort 9999
+
+ # The location of Tcl interpreter
+ set tclsh "/Users/yeung/bin/tcl/bin/tclsh8.5"
+
+ # The source code directory of the Tcl debugger
+ set libDir "/Users/yeung/Desktop/TclDebugger/src"
+
+ # The source code directory of the test project
+ set startDir "/Users/yeung/Desktop/test"
+
+2. Start Tcl debug server:
+ $ cd TclDebugger/src
+ $ export PATH=/Users/yeung/bin/tcl/bin:$PATH
+ $ tclsh8.5 debugger.tcl
+
+3. Luanch Speare Pro and start debugging session.
+ a. select the start script
+ b. add breakpoints
+ c. click "Start" button on the debug toolbar of Speare code editor.
+ d. step in, step out, step next, ...
+
+4. Customise the debugger
+ a. add filter to ignore variable dump.
+ modify the proc dbg::dumpStack in dbg.tcl
+
+ b. add filter to ignore folder and file Instrument
+ modify the proc dbg::Instrument in dbg.tcl
+
+ This is useful when you don't want to trace into
+ the code of some library.
+
+ Note: It's not necessary to add these filters in common debugging situation.
+
+
+
+Dec 18 2019
+
+
+
+
+
--- /dev/null
+# The Tcl debugger for Speare code editor.
+# Copyright (c) 1998-2000 Ajuba Solutions
+# Copyright (c) 2019 sevenuc.com. All rights reserved.
+#
+# THIS FILE IS PART OF SPEARE CODE EDITOR. WITHOUT THE
+# WRITTEN PERMISSION OF THE AUTHOR THIS FILE MAY NOT
+# BE USED FOR ANY COMMERCIAL PRODUCT.
+#
+# More info:
+# http://sevenuc.com/en/Speare.html
+# Contact:
+# Sevenuc support <info@sevenuc.com>
+# Issue report and requests pull:
+# https://github.com/chengdu/Speare
+
+
+# DbgNub_Main --
+#
+# Initializes the nub and invokes the client script.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc DbgNub_Main {} {
+ global argc argv0 argv errorCode errorInfo tcl_version
+
+ if {$argc < 4} {
+ error "$argv0 needs cmd line args: hostname port scriptName data ?args?"
+ }
+
+ # Parse command line arguments
+
+ set libDir [file dirname $argv0]
+ set host [lindex $argv 0]
+ set port [lindex $argv 1]
+ set script [lindex $argv 2]
+ set data [lindex $argv 3]
+ set argList [lrange $argv 4 end]
+
+ # Set up replacement arguments so the client script doesn't see the
+ # appLaunch arguments.
+
+ set argv0 $script
+ set argv $argList
+ set argc [llength $argList]
+
+ # The following code needs to be kept in sync with initdebug.tcl
+
+ if {[catch {set socket [socket $host $port]}] != 0} {
+ puts "appLaunch can't create socket"
+ exit 1
+ }
+ fconfigure $socket -blocking 1 -translation binary
+
+ # On 8.1 and later versions we should ensure the socket is not doing
+ # any encoding translations.
+
+ if {$tcl_version >= 8.1} {
+ fconfigure $socket -encoding utf-8
+ }
+
+ # Attach to the debugger as a local app.
+
+ set msg [list HELLO 1.0 $tcl_version $data]
+ puts $socket [string length $msg]
+ puts -nonewline $socket $msg
+ flush $socket
+
+ # Get the rest of the nub library and evaluate it in the current scope.
+ # Note that the nub code assumes there will be a "socket" variable that
+ # contains the debugger socket channel.
+
+ if {[gets $socket bytes] == -1} {
+ puts "appLaunch read nub failed."
+ exit 1
+ }
+ set msg [read $socket $bytes]
+
+ eval [lindex $msg 1]
+ return
+}
+
+DbgNub_Main
+source $argv0
+
--- /dev/null
+# The Tcl debugger for Speare code editor.
+# Copyright (c) 1998-2000 Ajuba Solutions
+# Copyright (c) 2019 sevenuc.com. All rights reserved.
+#
+# THIS FILE IS PART OF SPEARE CODE EDITOR. WITHOUT THE
+# WRITTEN PERMISSION OF THE AUTHOR THIS FILE MAY NOT
+# BE USED FOR ANY COMMERCIAL PRODUCT.
+#
+# More info:
+# http://sevenuc.com/en/Speare.html
+# Contact:
+# Sevenuc support <info@sevenuc.com>
+# Issue report and requests pull:
+# https://github.com/chengdu/Speare
+
+
+package provide blk 1.0
+namespace eval blk {
+ # block data type --
+ #
+ # A block encapsulates the state associated with a unit of
+ # instrumented code. Each block is represented by a Tcl array
+ # whose name is of the form blk<num> and contains the
+ # following elements:
+ # file The name of the file that contains this
+ # block. May be null if the block contains
+ # dynamic code.
+ # script The original uninstrumented script.
+ # version A version counter for the contents of
+ # the block.
+ # instrumented Indicates that a block represents instrumented
+ # code.
+ # lines A list of line numbers in the script that
+ # contain the start of a debugged statement.
+ # These are valid breakpoint lines.
+ #
+ # Fields:
+ # blockCounter This counter is used to generate block names.
+ # blockFiles This array maps from file names to blocks.
+ # blkTemp This block is the shared temporary block. It is
+ # used for showing uninstrumented code.
+
+ variable blockCounter 0
+ array set blockFiles {}
+ array set blkTemp {file {} version 0 instrumented 0 script {} lines {}}
+}
+# end namespace blk
+
+# blk::makeBlock --
+#
+# Retrieve the block associated with a file, creating a new
+# block if necessary.
+#
+# Arguments:
+# file The file that contains the block or {} for dynamic blocks.
+#
+# Results:
+# Returns the block identifier.
+
+proc blk::makeBlock {file} {
+ variable blockCounter
+ variable blockFiles
+
+ # check to see if the block already exists
+
+ #set formatFile [system::formatFilename $file]
+ set formatFile $file
+
+ if {[info exists blockFiles($formatFile)]} {
+ return $blockFiles($formatFile)
+ }
+
+ # find an unallocated block number and create the array
+
+ incr blockCounter
+ while {[info exists ::blk::blk$blockCounter]} {
+ incr blockCounter
+ }
+ array set ::blk::blk${blockCounter} [list \
+ file $file \
+ version 0 \
+ instrumented 0 lines {}]
+
+ # don't create an entry for dynamic blocks
+
+ if {$file != ""} {
+ set blockFiles($formatFile) $blockCounter
+ }
+ return $blockCounter
+}
+
+# blk::release --
+#
+# Release the storage associated with one or more blocks.
+#
+# Arguments:
+# args The blocks to release, "dynamic" to release all dynamic
+# blocks, or "all" to release all blocks.
+#
+# Results:
+# None.
+
+proc blk::release {args} {
+ if {$args == "dynamic"} {
+ foreach block [info var ::blk::blk*] {
+ if {[set ${block}(file)] == ""} {
+ unset $block
+ }
+ }
+ } elseif {$args == "all"} {
+ if {[info exists ::blk::blockFiles]} {
+ unset ::blk::blockFiles
+ }
+ set all [info var ::blk::blk*]
+ if {$all != ""} {
+ eval unset $all
+ }
+ } else {
+ foreach block $args {
+ if {! [info exists ::blk::blk$block]} {
+ continue
+ }
+ set file [getFile $block]
+ if {$file != ""} {
+ #unset ::blk::blockFiles([system::formatFilename $file])
+ unset ::blk::blockFiles($file)
+ }
+ unset ::blk::blk$block
+ }
+ }
+
+ if {! [info exists ::blk::blkTemp]} {
+ array set ::blk::blkTemp {file {} version 0 instrumented 0 script {}
+ lines {}}
+ }
+}
+
+# blk::exists --
+#
+# Determine if the block still exists.
+#
+# Arguments:
+# blockNum The block to check for existence.
+#
+# Results:
+# Return 1 if the block exists.
+
+proc blk::exists {blockNum} {
+ return [info exists ::blk::blk${blockNum}(instrumented)]
+}
+
+
+# blk::getSource --
+#
+# Return the script associated with a block. If block's script
+# has never been set, open the file and read the contents.
+#
+# Arguments:
+# blockNum The block number.
+#
+# Results:
+# Returns the script.
+
+proc blk::getSource {blockNum} {
+ upvar #0 ::blk::blk$blockNum block
+
+ if {[info exists block(script)]} {
+ return $block(script)
+ } elseif {$block(file) != ""} {
+ set fd [open $block(file) r]
+ set script [read $fd]
+ close $fd
+ incr block(version)
+ return $script
+ } else {
+ return ""
+ }
+}
+
+# blk::getFile --
+#
+# Return the name associated with the given block.
+#
+# Arguments:
+# blockNum The block number.
+#
+# Results:
+# Returns the file name or {} if the block is dynamic.
+
+proc blk::getFile {blockNum} {
+ return [set ::blk::blk${blockNum}(file)]
+}
+
+# blk::getLines --
+#
+# Return the list of line numbers that represent valid
+# break-points for this block. If the block does not
+# exist or the block is not instrumented we return -1.
+#
+# Arguments:
+# blockNum The block number.
+#
+# Results:
+# Returns a list of line numbers.
+
+proc blk::getLines {blockNum} {
+ if {! [info exists ::blk::blk${blockNum}(instrumented)] \
+ || ! [set ::blk::blk${blockNum}(instrumented)]} {
+ return -1
+ }
+ return [set ::blk::blk${blockNum}(lines)]
+}
+
+# blk::getRanges --
+#
+# Return the list of ranges that represent valid
+# break-pints for this block. If the block does not
+# exist or the block is not instrumented, we return -1.
+#
+# Arguments:
+# blockNum The block number.
+#
+# Results:
+# Returns a list of range numbers.
+
+proc blk::getRanges {blockNum} {
+ if {! [info exists ::blk::blk${blockNum}(instrumented)]} {
+ return -1
+ }
+ if {! [set ::blk::blk${blockNum}(instrumented)]} {
+ return -1
+ }
+ return [lsort [set ::blk::blk${blockNum}(ranges)]]
+}
+
+# blk::Instrument --
+#
+# Set the source script associated with a block and return the
+# instrumented form.
+#
+# Arguments:
+# blockNum The block number.
+# script The new source for the block that should be
+# instrumented.
+#
+# Results:
+# Returns the instrumented script.
+
+proc blk::Instrument {blockNum script} {
+ SetSource $blockNum $script
+ set script [instrument::Instrument $blockNum]
+
+ # Don't mark the block as instrumented unless we have successfully
+ # completed instrumentation.
+
+ if {$script != ""} {
+ set ::blk::blk${blockNum}(instrumented) 1
+
+ # Compute the sorted list of line numbers containing statements.
+ # We need to suppress duplicates since there may be more than one
+ # statement per line.
+
+ if {[info exists tmp]} {
+ unset tmp
+ }
+ foreach x $::instrument::lines {
+ set tmp($x) ""
+ }
+
+ # Ensure that the lines are in numerically ascending order.
+
+ set ::blk::blk${blockNum}(lines) [lsort -integer [array names tmp]]
+
+ # Get the coverable ranges for this block.
+
+ set ::blk::blk${blockNum}(ranges) $::instrument::ranges
+ }
+ return $script
+}
+
+# blk::isInstrumented --
+#
+# Test whether a block has been instrumented.
+#
+# Arguments:
+# blockNum The block number.
+#
+# Results:
+# Returns 1 if the block is instrumented else 0.
+
+proc blk::isInstrumented {blockNum} {
+ if {[catch {set ::blk::blk${blockNum}(instrumented)} result]} {
+ return 0
+ }
+ return $result
+}
+
+# blk::unmarkInstrumented --
+#
+# Mark all the instrumented blocks as uninstrumented. If it's
+# a block to a file remove the source.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc blk::unmarkInstrumented {} {
+ foreach block [info var ::blk::blk*] {
+ if {[set ${block}(instrumented)] == 1} {
+ set ${block}(instrumented) 0
+ if {[set ${block}(file)] != ""} {
+ unset ${block}(script)
+ }
+ }
+ }
+ return
+}
+
+# blk::getVersion --
+#
+# Retrieve the source version for the block.
+#
+# Arguments:
+# blockNum The block number.
+#
+# Results:
+# Returns the version number.
+
+proc blk::getVersion {blockNum} {
+ return [set ::blk::blk${blockNum}(version)]
+}
+
+# blk::getFiles --
+#
+# This function retrieves all of the blocks that are associated
+# with files.
+#
+# Arguments:
+# None.
+#
+# Results:
+# Returns a list of blocks.
+
+proc blk::getFiles {} {
+ set result {}
+ foreach name [array names ::blk::blockFiles] {
+ lappend result $::blk::blockFiles($name)
+ }
+ return $result
+}
+
+# blk::SetSource --
+#
+# This routine sets the script attribute of a block and incremenets
+# the version number.
+#
+# Arguments:
+# blockNum The block number.
+# script The new contents of the block.
+#
+# Results:
+# None.
+
+proc blk::SetSource {blockNum script} {
+ set ::blk::blk${blockNum}(script) $script
+ incr ::blk::blk${blockNum}(version)
+ return
+}
+
+# blk::isDynamic --
+#
+# Check whether the current block is associated with a file or
+# is a dynamic block.
+#
+# Arguments:
+# blockNum The block number.
+#
+# Results:
+# Returns 1 if the block is not associated with a file.
+
+proc blk::isDynamic {blockNum} {
+ return [expr {[set ::blk::blk${blockNum}(file)] == ""}]
+}
+
--- /dev/null
+# The Tcl debugger for Speare code editor.
+# Copyright (c) 1998-2000 Ajuba Solutions
+# Copyright (c) 2019 sevenuc.com. All rights reserved.
+#
+# THIS FILE IS PART OF SPEARE CODE EDITOR. WITHOUT THE
+# WRITTEN PERMISSION OF THE AUTHOR THIS FILE MAY NOT
+# BE USED FOR ANY COMMERCIAL PRODUCT.
+#
+# More info:
+# http://sevenuc.com/en/Speare.html
+# Contact:
+# Sevenuc support <info@sevenuc.com>
+# Issue report and requests pull:
+# https://github.com/chengdu/Speare
+
+
+package provide break 1.0
+namespace eval break {
+ # breakpoint data type --
+ #
+ # A breakpoint object encapsulates the state associated with a
+ # breakpoint. Each breakpoint is represented by a Tcl array
+ # whose name is of the form break<type><num> where <type> is
+ # L for line-based breakpoints and V for variable breakpoints.
+ # Each array contains the following elements:
+ # state Either enabled or disabled.
+ # test The script in conditional breakpoints.
+ # location The location or trace handle for the
+ # breakpoint.
+ # data This field holds arbitrary data associated
+ # with the breakpoint for use by the GUI.
+ #
+ # Fields:
+ # counter This counter is used to generate breakpoint names.
+
+ variable counter 0
+}
+# end namespace break
+
+# break::MakeBreakpoint --
+#
+# Create a new breakpoint.
+#
+# Arguments:
+# type One of "line" or "var"
+# where Location for line breakpoints; trace handle for
+# variable breakpoints.
+# test Optional. Script to use for conditional breakpoint.
+#
+# Results:
+# Returns a breakpoint identifier.
+
+proc break::MakeBreakpoint {type location {test {}}} {
+ variable counter
+
+ if {$type == "line"} {
+ set type L
+ } else {
+ set type V
+ }
+
+ # find an unallocated breakpointer number and create the array
+
+ incr counter
+ while {[info exists ::break::break$type$counter]} {
+ incr counter
+ }
+ set name $type$counter
+ array set ::break::break$name \
+ [list data {} location $location state enabled test $test]
+ return $name
+}
+
+# break::Release --
+#
+# Release the storage associated with one or more breakpoints.
+#
+# Arguments:
+# breakList The breakpoints to release, or "all".
+#
+# Results:
+# None.
+
+proc break::Release {breakList} {
+ if {$breakList == "all"} {
+ # Release all breakpoints
+ set all [info vars ::break::break*]
+ if {$all != ""} {
+ eval unset $all
+ }
+ } else {
+ foreach breakpoint $breakList {
+ if {[info exist ::break::break$breakpoint]} {
+ unset ::break::break$breakpoint
+ }
+ }
+ }
+ return
+}
+
+# break::getState --
+#
+# Return the breakpoint state.
+#
+# Arguments:
+# breakpoint The breakpoint identifier.
+#
+# Results:
+# Returns one of enabled or disabled.
+
+proc break::getState {breakpoint} {
+ return [set ::break::break${breakpoint}(state)]
+}
+
+# break::getLocation --
+#
+# Return the breakpoint location.
+#
+# Arguments:
+# breakpoint The breakpoint identifier.
+#
+# Results:
+# Returns the breakpoint location.
+
+proc break::getLocation {breakpoint} {
+ return [set ::break::break${breakpoint}(location)]
+}
+
+
+# break::getTest --
+#
+# Return the breakpoint test.
+#
+# Arguments:
+# breakpoint The breakpoint identifier.
+#
+# Results:
+# Returns the breakpoint test.
+
+proc break::getTest {breakpoint} {
+ return [set ::break::break${breakpoint}(test)]
+}
+
+# break::getType --
+#
+# Return the type of the breakpoint.
+#
+# Arguments:
+# breakpoint The breakpoint identifier.
+#
+# Results:
+# Returns the breakpoint type; one of "line" or "var".
+
+proc break::getType {breakpoint} {
+ switch [string index $breakpoint 0] {
+ V {
+ return "var"
+ }
+ L {
+ return "line"
+ }
+ }
+ error "Invalid breakpoint type"
+}
+
+
+# break::SetState --
+#
+# Change the breakpoint state.
+#
+# Arguments:
+# breakpoint The breakpoint identifier.
+# state One of enabled or disabled.
+#
+# Results:
+# None.
+
+proc break::SetState {breakpoint state} {
+ set ::break::break${breakpoint}(state) $state
+ return
+}
+
+# break::getData --
+#
+# Retrieve the client data field.
+#
+# Arguments:
+# breakpoint The breakpoint identifier.
+#
+# Results:
+# Returns the data field.
+
+proc break::getData {breakpoint} {
+ return [set ::break::break${breakpoint}(data)]
+}
+
+# break::setData --
+#
+# Set the client data field.
+#
+# Arguments:
+# breakpoint The breakpoint identifier.
+#
+# Results:
+# None.
+
+proc break::setData {breakpoint data} {
+ set ::break::break${breakpoint}(data) $data
+ return
+}
+
+# break::GetLineBreakpoints --
+#
+# Returns a list of all line-based breakpoint indentifiers. If the
+# optional location is specified, only breakpoints set at that
+# location are returned.
+#
+# Arguments:
+# location Optional. The location of the breakpoint to get.
+#
+# Results:
+# Returns a list of all line-based breakpoint indentifiers.
+
+proc break::GetLineBreakpoints {{location {}}} {
+ set result {}
+ foreach breakpoint [info vars ::break::breakL*] {
+ if {($location == "") \
+ || [loc::match $location [set ${breakpoint}(location)]]} {
+ lappend result $breakpoint
+ }
+ }
+
+ regsub -all {::break::break} $result {} result
+ return $result
+}
+
+# break::GetVarBreakpoints --
+#
+# Returns a list of all variable-based breakpoint indentifiers
+# for a specified variable trace.
+#
+# Arguments:
+# handle The trace handle.
+#
+# Results:
+# A list of breakpoint identifiers.
+
+proc break::GetVarBreakpoints {{handle {}}} {
+ set result {}
+ foreach breakpoint [info vars ::break::breakV*] {
+ if {($handle == "") \
+ || ([set ${breakpoint}(location)] == $handle)} {
+ lappend result $breakpoint
+ }
+ }
+ regsub -all {::break::break} $result {} result
+ return $result
+}
+
+# break::preserveBreakpoints --
+#
+# Generate a persistent representation for all line-based
+# breakpoints so they can be stored in the user preferences.
+#
+# Arguments:
+# varName Name of variable where breakpoint info should
+# be stored.
+#
+# Results:
+# None.
+
+proc break::preserveBreakpoints {varName} {
+ upvar $varName data
+ set data {}
+ foreach bp [GetLineBreakpoints] {
+ set location [getLocation $bp]
+ set file [blk::getFile [loc::getBlock $location]]
+ set line [loc::getLine $location]
+ if {$file != ""} {
+ lappend data [list $file $line [getState $bp] \
+ [getTest $bp]]
+ }
+ }
+ return
+}
+
+# break::restoreBreakpoints --
+#
+# Recreate a set of breakpoints from a previously preserved list.
+#
+# Arguments:
+# data The data generated by a previous call to
+# preserveBreakpoints.
+#
+# Results:
+# None.
+
+proc break::restoreBreakpoints {data} {
+ foreach bp $data {
+ set block [blk::makeBlock [lindex $bp 0]]
+ set location [loc::makeLocation $block [lindex $bp 1]]
+ SetState [MakeBreakpoint "line" $location [lindex $bp 3]] \
+ [lindex $bp 2]
+ }
+ return
+}
--- /dev/null
+# The Tcl debugger for Speare code editor.
+# Copyright (c) 1998-2000 Ajuba Solutions
+# Copyright (c) 2019 sevenuc.com. All rights reserved.
+#
+# THIS FILE IS PART OF SPEARE CODE EDITOR. WITHOUT THE
+# WRITTEN PERMISSION OF THE AUTHOR THIS FILE MAY NOT
+# BE USED FOR ANY COMMERCIAL PRODUCT.
+#
+# More info:
+# http://sevenuc.com/en/Speare.html
+# Contact:
+# Sevenuc support <info@sevenuc.com>
+# Issue report and requests pull:
+# https://github.com/chengdu/Speare
+
+
+package require parser
+
+namespace eval dbg {
+
+ # debugging options --
+ #
+ # Fields:
+ # debug Set to 1 to enable debugging output.
+ # logFile File handle where logging messages should be written.
+ # logFilter If non-null, contains a regular expression that will
+ # be compared with the message type. If the message
+ # type does not match, it is not logged.
+
+ variable debug 0
+ variable logFile stderr
+ variable logFilter {}
+
+ # startup options --
+ #
+ # Fields:
+ # libDir The directory that contains the debugger scripts.
+
+ variable libDir {}
+
+ # nub communication data structure --
+ #
+ # Communication with the nub is performed using a socket. The
+ # debugger creates a server socket that a nub will connect to
+ # when starting. If the nub is started by the debugger, then
+ # the process id is also recorded.
+ #
+ # Fields:
+ # nubSocket Socket to use to communicate with the
+ # currently connected nub. Set to -1 if no
+ # nub is currently connected.
+ # serverSocket Socket listening for nub connect requests.
+ # serverPort Port that the server is listening on.
+ # appPid Process ID for application started by the debugger.
+ # appHost Name of host that nub is running on.
+ # appVersion The tcl_version of the running app.
+
+ variable nubSocket -1
+ variable serverSocket -1
+ variable serverPort -1
+ variable appPid
+ variable appHost {}
+ variable appVersion {}
+
+ # application state data structure --
+ #
+ # appState One of running, stopped, or dead.
+ # currentPC Location information for statement where the app
+ # last stopped.
+ # currentLevel Current scope level for use in uplevel and upvar.
+ # stack Current virtual stack.
+
+ variable appState "dead"
+ variable currentPC {}
+ variable currentLevel 0
+ variable stack {}
+
+ # debugger events --
+ #
+ # Asynchronous changes in debugger state will be reported to the GUI
+ # via event callbacks. The set of event types includes:
+ #
+ # any Any of the following events fire.
+ # attach A new client application has just attached to the
+ # debugger but has not stopped yet.
+ # linebreak The client application hit a line breakpoint.
+ # varbreak The client application hit a variable breakpoint.
+ # userbreak The client application hit a debugger_break command.
+ # exit The application has terminated.
+ # result An async eval completed. The result string
+ # is appended to the callback script.
+ # error An error occurred in the script. The error message,
+ # error info, and error code are appended to the script.
+ # cmdresult The client application completed the current command
+ # and is stopped waiting to display the result. The
+ # result string is appended to the callback script.
+ #
+ # All of the handlers for an event are stored as a list in the
+ # registeredEvent array indexed by event type.
+
+ variable registeredEvent
+ variable validEvents {
+ any attach instrument linebreak varbreak userbreak
+ error exit result cmdresult stackinfo
+ }
+
+ # evaluate id generation --
+ #
+ # evalId A unique number used as the return ID for
+ # a call to dbg::evaluate.
+
+ variable evalId 0
+
+ # temporary breakpoint --
+ #
+ # tempBreakpoint The current run-to-line breakpoint.
+
+ variable tempBreakpoint {}
+}
+# end namespace dbg
+
+# dbg::start --
+#
+# Starts the application. Generates an error is one is already running.
+#
+# Arguments:
+# application The shell in which to run the script.
+# startDir the directory where the client program should be
+# started.
+# script The script to run in the application.
+# argList A list of commandline arguments to pass to the script.
+# clientData An opaque piece of data that will be passed through
+# to the nub and returned on the Attach event.
+#
+# Results:
+# None.
+
+proc dbg::start {application startDir script argList clientData} {
+ variable appState
+ variable libDir
+ variable serverPort
+
+ if {$appState != "dead"} {
+ error "dbg::start called with an app that is already started."
+ }
+
+ set oldDir [pwd]
+
+ # Determine the start directory. Relative paths are computed from the
+ # debugger startup directory.
+
+ if {[catch {
+ # If the start directory is blank, use the debugger startup directory,
+ # otherwise use the specified directory.
+
+ if { $startDir != "" } {
+ cd $startDir
+ }
+
+ # start up the application
+
+ if {$::tcl_platform(platform) == "windows"} {
+
+ } else {
+ set args ""
+ # Ensure that the argument string is a valid Tcl list so we can
+ # safely pass it through eval.
+
+ if {[catch {
+ foreach arg $argList {
+ lappend args $arg
+ }
+ }]} {
+ # The list wasn't valid so fall back to splitting on
+ # spaces and ignoring null values.
+
+ foreach arg [split [string trim $argList]] {
+ if {$arg != ""} {
+ lappend args $arg
+ }
+ }
+ }
+
+ set _argv [list 127.0.0.1 $serverPort $script $clientData {*}$args]
+ set _argc [llength $_argv]
+ lappend _input variable argc $_argc argv $_argv
+
+ puts "exec appLaunch.tcl"
+ set f [open [file join $libDir appLaunch.tcl]]
+ exec $application <<$_input\n[read $f] &
+ close $f
+ }
+ } msg]} {
+ # Make sure to restore the original directory before throwing
+ # the error.
+
+ cd $oldDir
+ error $msg $::errorInfo $::errorCode
+ }
+ cd $oldDir
+ return
+}
+
+# dbg::kill --
+#
+# Kills the current application. Generates an error if the application
+# is already dead.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc dbg::kill {} {
+ variable appState
+ variable nubSocket
+ variable appHost
+ variable appPid
+ variable tempBreakpoint
+
+ if {$appState == "dead"} {
+ error "dbg::kill called with an app that is already dead."
+ }
+
+ # Try to kill the application process.
+ if {[dbg::isLocalhost]} {
+ catch {::kill $appPid}
+ }
+
+ HandleClientExit
+ return
+}
+
+# dbg::step --
+#
+# Runs the currently stopped application to the next instrumented
+# statement (at the level specified, if one is specified).
+# Generates an error if an application is currently running.
+#
+# Arguments:
+# level The stack level at which to stop in the next instrumented
+# statement.
+#
+# Results:
+# None.
+
+proc dbg::step {{level any}} {
+ variable appState
+
+ if {$appState != "stopped"} {
+ #error "dbg::step called with an app that is not stopped."
+ puts "dbg::step called with an app that is not stopped."
+ return
+ }
+ set appState "running"
+
+ Log timing {DbgNub_Run $level}
+ SendAsync DbgNub_Run $level
+ return
+}
+
+# dbg::evaluate --
+#
+# This command causes the application to evaluate the given script
+# at the specified level. When the script completes, a result
+# event is generated.
+# Generates an error if the application is not currently stopped.
+#
+# Arguments:
+# level The stack level at which to evaluate the script.
+# script The script to be evaluated by the application.
+#
+# Results:
+# Returns a unqiue id for this avaluate. The id can be used
+# to match up the returned result.
+
+proc dbg::evaluate {level script} {
+ variable appState
+ variable currentLevel
+ variable evalId
+
+ if {$appState != "stopped"} {
+ #error "dbg::evaluate called with an app that is not stopped."
+ puts "dbg::evaluate called with an app that is not stopped."
+ return
+ }
+
+ if {$currentLevel < $level} {
+ #error "dbg::evaluate called with invalid level \"$level\""
+ puts "dbg::evaluate called with invalid level \"$level\""
+ return
+ }
+
+ incr evalId
+ SendAsync DbgNub_Evaluate $evalId $level $script
+ set appState "running"
+
+ return $evalId
+}
+
+# dbg::run --
+#
+# Runs the currently stopped application to either completion or the
+# next breakpoint. Generates an error if an application is not
+# currently stopped.
+#
+# Arguments:
+# location Optional. Specifies the location for a temporary
+# breakpoint that will be cleared the next time the
+# application stops.
+#
+# Results:
+# None.
+
+proc dbg::run {{location {}}} {
+ variable appState
+ variable tempBreakpoint
+
+ if {$appState != "stopped"} {
+ #error "dbg::run called with an app that is not stopped."
+ puts "dbg::run called with an app that is not stopped."
+ return
+ }
+
+ # If requested, set a temporary breakpoint at the specified location.
+
+ if {$location != ""} {
+ set tempBreakpoint [dbg::addLineBreakpoint $location]
+ }
+
+ # Run until the next breakpoint
+ set appState "running"
+ SendAsync DbgNub_Run
+
+ return
+}
+
+# dbg::interrupt --
+#
+# Interrupts the currently running application by stopping at the next
+# instrumented statement or breaking into the event loop.
+# Generates an error if no application is currently running.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc dbg::interrupt {} {
+ variable appState
+
+ if {$appState != "running"} {
+ error "dbg::interrupt called with an app that is not running."
+ }
+
+ # Stop at the next instrumented statement
+
+ SendAsync DbgNub_Interrupt
+
+ return
+}
+
+# dbg::register --
+#
+# Adds a callback for the specified event type. If the event is
+# not a valid event, an error is generated.
+#
+# Arguments:
+# event Type of event on which to make the callback.
+# script Code to execute when a callback is made.
+#
+# Results:
+# None.
+
+proc dbg::register {event script} {
+ variable registeredEvent
+ variable validEvents
+
+ if {[lsearch $validEvents $event] == -1} {
+ error "dbg::register called with invalid event \"$event\""
+ }
+ lappend registeredEvent($event) $script
+ return
+}
+
+# dbg::unregister --
+#
+# Removes the callback specified by the event and script. If the
+# specified script is not already registered with the given event,
+# an error is generated.
+#
+# Arguments:
+# event Type of event whose callback to remove.
+# script The script that was registered with the given event type.
+#
+# Results:
+# None.
+
+proc dbg::unregister {event script} {
+ variable registeredEvent
+
+ if {[info exists registeredEvent($event)]} {
+
+ set i [lsearch $registeredEvent($event) $script]
+
+ if {$i == -1} {
+ error "dbg::unregister called with non-registered script \"$script\"."
+ }
+ set registeredEvent($event) [lreplace $registeredEvent($event) $i $i]
+ return
+ }
+ error "dbg::unregister called with non-registered event \"$event\"."
+}
+
+# dbg::DeliverEvent --
+#
+# Deliver an event to any scripts that have registered
+# interest in the event.
+#
+# Arguments:
+# event The event to deliver.
+# args Any arguments that should be passed to the script.
+# Note that we need to be careful here since the data
+# may be coming from untrusted code and may be dangerous.
+#
+# Results:
+# None.
+
+#instrument end $block
+proc dbg::DeliverEvent {event args} {
+ variable registeredEvent
+
+ # Break up args and reform it as a valid list so we can safely pass it
+ # through uplevel.
+
+ set newList {}
+ foreach arg $args {
+ lappend newList $arg
+ }
+
+ if {[info exists registeredEvent($event)]} {
+ foreach script $registeredEvent($event) {
+ uplevel #0 $script $newList
+ }
+ }
+ if {[info exists registeredEvent(any)]} {
+ foreach script $registeredEvent(any) {
+ uplevel #0 $script $event $newList
+ }
+ }
+
+ return
+}
+
+# dbg::getLevel --
+#
+# Returns the stack level at which the application is currently
+# running.
+# Generates an error if the application is not currently stopped.
+#
+# Arguments:
+# None.
+#
+# Results:
+# Returns the stack level at which the application is currently
+# running.
+
+proc dbg::getLevel {} {
+ variable appState
+ variable currentLevel
+
+ if {$appState != "stopped"} {
+ #error "dbg::getLevel called with an app that is not stopped."
+ puts "dbg::getLevel called with an app that is not stopped."
+ return
+ }
+
+ return $currentLevel
+}
+
+# dbg::getPC --
+#
+# Returns the location which the application is currently
+# executing.
+# Generates an error if the application is not currently stopped.
+#
+# Arguments:
+# None.
+#
+# Results:
+# Returns the location which the application is currently
+# executing.
+
+proc dbg::getPC {} {
+ variable appState
+ variable currentPC
+
+ if {$appState != "stopped"} {
+ #error "dbg::getPC called with an app that is not stopped."
+ puts "dbg::getPC called with an app that is not stopped."
+ return
+ }
+
+ return $currentPC
+}
+
+# dbg::getStack --
+#
+# Returns information about each frame on the current Tcl stack
+# up to the most closely nested global scope. The format of the
+# stack information is a list of elements that have the
+# following form:
+# {level location type args ...}
+# The level indicates the Tcl scope level, as used by uplevel.
+# The location refers to the location of the statement that is
+# currently executing (or about to be executed in the current
+# frame). The type determines how the remainder of the
+# arguments are to be interpreted and should be one of the
+# following values:
+# global The stack frame is outside of any procedure
+# scope. There are no additonal arguments.
+# proc The statement is inside a procedure. The
+# first argument is the procedure name and the
+# remaining arguments are the names of the
+# procedure arguments.
+# source This entry in the stack is a virtual frame
+# that corresponds to a change in block due to a
+# source command. There are no arguments.
+# Eventually we will want to provide support for other virtual
+# stack frames so we can handle other forms of dynamic code that
+# are executed in the current stack scope (e.g. eval). For now
+# we will only handle "source", since it is a critical case.
+#
+# Generates an error if the application is not currently stopped.
+#
+# Arguments:
+# None.
+#
+# Results:
+# Returns a list of stack locations of the following form:
+# {level location type args ...}
+
+proc dbg::getStack {} {
+ variable appState
+ variable stack
+
+ if {$appState != "stopped"} {
+ #error "dbg::getStack called with an app that is not stopped."
+ puts "dbg::getStack called with an app that is not stopped."
+ return
+ }
+
+ return $stack
+}
+
+# dbg::getProcs --
+#
+# Returns a list of all procedures in the application, excluding
+# those added by the debugger itself. The list consists of
+# elements of the form {<procname> <location>}, where the
+# location refers to the entire procedure definition. If the
+# procedure is uninstrumented, the location is null.
+# Generates an error if the application is not currently stopped.
+#
+# Arguments:
+# None.
+#
+# Results:
+# Returns a list of all procedures in the application, excluding
+# those added by the debugger itself. The list consists of
+# elements of the form {<procname> <location>}.
+
+proc dbg::getProcs {} {
+ variable appState
+
+ if {$appState != "stopped"} {
+ #error "dbg::getProcs called with an app that is not stopped."
+ puts "dbg::getProcs called with an app that is not stopped."
+ return
+ }
+
+ return [Send DbgNub_GetProcs]
+}
+
+# dbg::getProcLocation --
+#
+# Get a location that refers to the specified procedure. This
+# function only works on uninstrumented procedures because the
+# location will refer to an uninstrumented procedure block.
+#
+# Arguments:
+# name The name of the procedure.
+#
+# Results:
+# Returns a location that can be used to get the procedure
+# definition.
+
+proc dbg::getProcLocation {name} {
+ variable appState
+ if {$appState != "stopped"} {
+ #error "dbg::getProcLocation called with an app that is not stopped."
+ puts "dbg::getProcLocation called with an app that is not stopped."
+ return
+ }
+ blk::SetSource Temp [Send DbgNub_GetProcDef $name]
+ return [loc::makeLocation Temp 1]
+}
+
+# dbg::getProcBody --
+#
+# Given the location for an instrumented procedure we extract
+# the body of the procedure from the origional source and return
+# the uninstrumented body. This is used, for example, by the
+# info body command to return the origional body of code.
+#
+# Arguments:
+# loc The location of the procedure we want the body for.
+#
+# Results:
+# The uninstrumented body of the procedure.
+
+proc dbg::getProcBody {loc} {
+ # This function is more complicated that it would seem at first. The
+ # literal value from the script is an unsubstituted value, but we need the
+ # substituted value that the proc command would see. So, we need to parse
+ # the commaand as a list, extract the body argument and then create a new
+ # command to evaluate that will compute the resulting substituted body.
+ # If we don't do all of this, any backslash continuation characters won't
+ # get substituted and we'll end up with a subtly different body.
+
+ set script [blk::getSource [loc::getBlock $loc]]
+ set args [parse list $script [loc::getRange $loc]]
+ eval set body [parse getstring $script [lindex $args 3]]
+ return $body
+}
+
+# dbg::uninstrumentProc --
+#
+# Given a fully qualified procedure name that is currently
+# instrumented this procedure will insteract with the
+# application to redefine the procedure as un uninstrumented
+# procedure.
+#
+# Arguments:
+# procName A fully qualified procedure name.
+# loc This is the location tag for the procedure
+# passing this makes the implementation go
+# much faster.
+#
+# Results:
+# None.
+
+proc dbg::uninstrumentProc {procName loc} {
+ set body [dbg::getProcBody $loc]
+ SendAsync DbgNub_UninstrumentProc $procName $body
+ return
+}
+
+# dbg::instrumentProc --
+#
+# Given a fully qualified procedure name this function will
+# instrument the procedure body and redefine the proc to use
+# the new procedure body.
+#
+# Arguments:
+# procName A fully qualified procedure name.
+# loc The tmp loc for this procedure.
+#
+# Results:
+# None.
+
+proc dbg::instrumentProc {procName loc} {
+ set block [loc::getBlock $loc]
+ set iscript [Instrument {} [blk::getSource $block]]
+ SendAsync DbgNub_InstrumentProc $procName $iscript
+ return
+}
+
+# dbg::getVariables --
+#
+# Returns the list of variables that are visible at the specified
+# level.
+# Generates an error if the application is not currently stopped.
+#
+# Arguments:
+# level The stack level whose variables are returned.
+# vars List of variable names to fetch type info for.
+#
+# Results:
+# Returns the list of variables that are visible at the specified
+# level.
+
+proc dbg::getVariables {level {vars {}}} {
+ variable appState
+ variable currentLevel
+
+ if {$appState != "stopped"} {
+ #error "dbg::getVariables called with an app that is not stopped."
+ puts "dbg::getVariables called with an app that is not stopped."
+ return
+ }
+
+ if {$currentLevel < $level} {
+ #error "dbg::getVar called with invalid level \"$level\""
+ puts "dbg::getVar called with invalid level \"$level\""
+ return
+ }
+
+ return [Send DbgNub_GetVariables $level $vars]
+}
+
+# dbg::getVar --
+#
+# Returns a list containing information about each of the
+# variables specified in varList. The returned list consists of
+# elements of the form {<name> <type> <value>}. Type indicates
+# if the variable is scalar or an array and is either "s" or
+# "a". If the variable is an array, the result of an array get
+# is returned for the value, otherwise it is the scalar value.
+# Any names that were specified in varList but are not valid
+# variables will be omitted from the returned list.
+# Generates an error if the application is not currently stopped.
+#
+# Arguments:
+# level The stack level of the variables in varList.
+# maxlen The maximum length of any data element to fetch, may
+# be -1 to fetch everything.
+# varList A list of variables whose information is returned.
+#
+# Results:
+# Returns a list containing information about each of the
+# variables specified in varList. The returned list consists of
+# elements of the form {<name> <type> <value>}.
+
+proc dbg::getVar {level maxlen varList} {
+ variable appState
+ variable currentLevel
+
+ if {$appState != "stopped"} {
+ #error "dbg::getVar called with an app that is not stopped."
+ puts "dbg::getVar called with an app that is not stopped."
+ return
+ }
+
+ if {$currentLevel < $level} {
+ #error "dbg::getVar called with invalid level \"$level\""
+ puts "dbg::getVar called with invalid level \"$level\""
+ return
+ }
+
+ return [Send DbgNub_GetVar $level $maxlen $varList]
+}
+
+# dbg::setVar --
+#
+# Sets the value of a variable. If the variable is an array,
+# the value must be suitable for array set, or an error is
+# generated. If no such variable exists, an error is generated.
+# Generates an error if the application is not currently stopped.
+#
+# Arguments:
+# level The stack level of the variable to set.
+# var The name of the variable to set.
+# value The new value of var.
+#
+# Results:
+# None.
+
+proc dbg::setVar {level var value} {
+ variable appState
+ variable currentLevel
+
+ if {$appState != "stopped"} {
+ #error "dbg::setVar called with an app that is not stopped."
+ puts "dbg::setVar called with an app that is not stopped."
+ return
+ }
+
+ if {$currentLevel < $level} {
+ #error "dbg::setVar called with invalid level \"$level\""
+ puts "dbg::setVar called with invalid level \"$level\""
+ return
+ }
+
+ SendAsync DbgNub_SetVar $level $var $value
+ return
+}
+
+# dbg::getResult --
+#
+# Fetch the result and return code of the last instrumented statement
+# that executed.
+#
+# Arguments:
+# maxlen Truncate long values after maxlen characters.
+#
+# Results:
+# Returns the list of {code result}.
+
+proc dbg::getResult {maxlen} {
+ variable appState
+ if {$appState != "stopped"} {
+ #error "dbg::getVar called with an app that is not stopped."
+ puts "dbg::getVar called with an app that is not stopped."
+ return
+ }
+
+ return [Send DbgNub_GetResult $maxlen]
+}
+
+
+# dbg::addLineBreakpoint --
+#
+# Set a breakpoint at the given location. If no such location
+# exists, an error is generated.
+# Generates an error if an application is currently running.
+#
+# Arguments:
+# location The location of the breakpoint to add.
+#
+# Results:
+# Returns a breakpoint identifier.
+
+proc dbg::addLineBreakpoint {location} {
+ variable appState
+
+ set l [loc::getLine $location]
+ puts "dbg::addLineBreakpoint: $location:$l"
+
+ if {$appState != "dead"} {
+ SendAsync DbgNub_AddBreakpoint line $location
+ }
+
+ return [break::MakeBreakpoint line $location]
+}
+
+# dbg::getLineBreakpoints --
+#
+# Get the breakpoints that are set on a given line, or all
+# line breakpoints.
+#
+# Arguments:
+# location Optional. The location of the breakpoint to get.
+#
+# Results:
+# Returns a list of line-based breakpoint indentifiers.
+
+proc dbg::getLineBreakpoints {{location {}}} {
+ variable tempBreakpoint
+
+ set bps [break::GetLineBreakpoints $location]
+ if {$tempBreakpoint != ""} {
+ set index [lsearch -exact $bps $tempBreakpoint]
+ if {$index != -1} {
+ set bps [lreplace $bps $index $index]
+ }
+ }
+ return $bps
+}
+
+# dbg::validateBreakpoints --
+#
+# Get the list of prior bpts and valid bpts for the block.
+# Move invalid bpts that to nearest valid location.
+#
+# Arguments:
+# file The name of the file for this block.
+# blk Block for which to validate bpts.
+#
+# Results:
+# None.
+
+proc dbg::validateBreakpoints {file blk} {
+
+ set validLines [blk::getLines $blk]
+ set bpLoc [loc::makeLocation $blk {}]
+ set bpList [dbg::getLineBreakpoints $bpLoc]
+
+ set warning 0
+ foreach bp $bpList {
+ set line [loc::getLine [break::getLocation $bp]]
+ set newLine [dbg::binarySearch $validLines $line]
+ if {$newLine != $line} {
+ set newLoc [loc::makeLocation $blk $newLine]
+ set newBp [dbg::moveLineBreakpoint $bp $newLoc]
+ set warning 1
+ }
+ }
+
+ #puts "validateBreakpoints end."
+
+ return
+}
+
+# dbg::binarySearch --
+#
+# Find the nearest matching line on which to move an invalid bpt.
+# Find the nearest matching value to elt in ls.
+#
+# Arguments:
+# ls Sorted list of ints >= 0.
+# elt Integer to match.
+#
+# Results:
+# Returns the closest match or -1 if ls is empty.
+
+proc dbg::binarySearch {ls elt} {
+ set len [llength $ls]
+ if {$len == 0} {
+ return -1
+ }
+ if {$len == 1} {
+ return [lindex $ls 0]
+ }
+ if {$len == 2} {
+ set e0 [lindex $ls 0]
+ set e1 [lindex $ls 1]
+ if {$elt <= $e0} {
+ return $e0
+ } elseif {$elt < $e1} {
+ if {($elt - $e0) <= ($e1 - $elt)} {
+ return $e0
+ } else {
+ return $e1
+ }
+ } else {
+ return $e1
+ }
+ }
+ set middle [expr {$len / 2}]
+ set result [lindex $ls $middle]
+ if {$result == $elt} {
+ return $result
+ }
+ if {$result < $elt} {
+ return [dbg::binarySearch [lrange $ls $middle $len] $elt]
+ } else {
+ return [dbg::binarySearch [lrange $ls 0 $middle] $elt]
+ }
+}
+
+# dbg::addVarBreakpoint --
+#
+# Set a breakpoint on the given variable.
+#
+# Arguments:
+# level The level at which the variable is accessible.
+# name The name of the variable.
+#
+# Results:
+# Returns a new breakpoint handle.
+
+proc dbg::addVarBreakpoint {level name} {
+ variable appState
+
+ if {$appState != "stopped"} {
+ #error "dbg::addVarBreakpoint called with an app that is not stopped."
+ puts "dbg::addVarBreakpoint called with an app that is not stopped."
+ return
+ }
+
+ set handle [Send DbgNub_AddVarTrace $level $name]
+ SendAsync DbgNub_AddBreakpoint var $handle
+ return [break::MakeBreakpoint var $handle]
+}
+
+# dbg::getVarBreakpoints --
+#
+# Get the variable breakpoints that are set on a given variable.
+# If both level and name are null, then all variable breakpoints
+# are returned.
+#
+# Arguments:
+# level The level at which the variable is accessible.
+# name The name of the variable.
+#
+# Results:
+# The list of breakpoint handles.
+
+proc dbg::getVarBreakpoints {{level {}} {name {}}} {
+ variable appState
+
+ if {$appState != "stopped"} {
+ #error "dbg::getVarBreakpoints called with an app that is not stopped."
+ puts "dbg::getVarBreakpoints called with an app that is not stopped."
+ return
+ }
+ if {$level == ""} {
+ return [break::GetVarBreakpoints]
+ }
+ set handle [Send DbgNub_GetVarTrace $level $name]
+ if {$handle != ""} {
+ return [break::GetVarBreakpoints $handle]
+ }
+ return ""
+}
+
+# dbg::removeBreakpoint --
+#
+# Remove the specified breakpoint. If no such breakpoint
+# exists, an error is generated.
+# Generates an error if an application is currently running.
+#
+# Arguments:
+# breakpoint The identifier of the breakpoint to remove.
+#
+# Results:
+# None.
+
+proc dbg::removeBreakpoint {breakpoint} {
+ variable appState
+
+ if {$appState != "dead"} {
+ SendAsync DbgNub_RemoveBreakpoint [break::getType $breakpoint] \
+ [break::getLocation $breakpoint] [break::getTest $breakpoint]
+ if {[break::getType $breakpoint] == "var"} {
+ SendAsync DbgNub_RemoveVarTrace [break::getLocation $breakpoint]
+ }
+ }
+
+ break::Release $breakpoint
+ return
+}
+
+# dbg::moveLineBreakpoint --
+#
+# Remove the specified breakpoint. If no such breakpoint
+# exists, an error is generated. Add a new breakpoint on the
+# specified line.
+# Generates an error if an application is currently running.
+#
+# Arguments:
+# breakpoint The identifier of the breakpoint to move.
+# newLoc The new location for the breakpoint.
+#
+# Results:
+# Returnes the new breakpoint or "" if none was added.
+
+proc dbg::moveLineBreakpoint {breakpoint newLoc} {
+ variable appState
+
+ set removedBpState [break::getState $breakpoint]
+ dbg::removeBreakpoint $breakpoint
+
+ # If there's already a bpt on "line"
+ # and it's enabled, then do nothing.
+ # and we removed a disabled one, then do nothing.
+ # Otherwise, remove any pre-existing bpts, and add "breakpoint"
+ # to its new line.
+
+ set priorBpts [break::GetLineBreakpoints $newLoc]
+ if {[llength $priorBpts] > 0} {
+ if {$removedBpState == "disabled"} {
+ return ""
+ }
+ foreach priorBpt $priorBpts {
+ if {[break::getState $priorBpt] != "disabled"} {
+ return ""
+ }
+ }
+ foreach priorBpt $priorBpts {
+ dbg::removeBreakpoint $priorBpt
+ }
+ }
+ return [dbg::addLineBreakpoint $newLoc]
+}
+
+# dbg::disableBreakpoint --
+#
+# Disable (without removing) the specified breakpoint. If no such
+# breakpoint exists or if the breakpoint is already disabled, an
+# error is generated.
+# Generates an error if an application is currently running.
+#
+# Arguments:
+# breakpoint The identifier of the breakpoint to disable.
+#
+# Results:
+# None.
+
+proc dbg::disableBreakpoint {breakpoint} {
+ variable appState
+
+ if {$appState != "dead"} {
+ SendAsync DbgNub_RemoveBreakpoint [break::getType $breakpoint] \
+ [break::getLocation $breakpoint] [break::getTest $breakpoint]
+ }
+
+ break::SetState $breakpoint disabled
+ return
+}
+
+# dbg::enableBreakpoint --
+#
+# Enable the specified breakpoint. If no such breakoint exists
+# or if the breakpoint is already enabled, an error is generated.
+# Generates an error if an application is currently running.
+#
+# Arguments:
+# breakpoint The identifier of the breakpoint to enable.
+#
+# Results:
+# None.
+
+proc dbg::enableBreakpoint {breakpoint} {
+ variable appState
+
+ if {$appState != "dead"} {
+ SendAsync DbgNub_AddBreakpoint [break::getType $breakpoint] \
+ [break::getLocation $breakpoint] [break::getTest $breakpoint]
+ }
+
+ break::SetState $breakpoint enabled
+ return
+}
+
+# dbg::initialize --
+#
+# Initialize the debugger engine. Intializes the library
+# directory for the debugger.
+#
+# Arguments:
+# dir Optional. The directory containing the debugger
+# scripts.
+#
+# Results:
+# None.
+
+proc dbg::initialize {{dir {}}} {
+ variable libDir
+
+ # Find the library directory for the debugger. If one is not specified
+ # look in the directory containing the startup script.
+
+ if {$dir == {}} {
+ set libDir [file dir [info nameofexecutable]]
+ } else {
+ set libDir $dir
+ }
+
+ set oldcwd [pwd]
+ cd $libDir
+ set libDir [pwd]
+ cd $oldcwd
+
+ return
+}
+
+# dbg::setServerPort --
+#
+# This function sets the server port that the debugger listens on.
+# If another port is opened for listening, it is closed before the
+# new port is opened.
+#
+# Arguments:
+# port The new port number the users wants. If the
+# port arg is set to "random" then we find a
+# suitable port in a standard range.
+#
+# Results:
+# Return 1 if the new port was available and is now being used,
+# returns 0 if we couldn't open the new port for some reason.
+# The old port will still work if we fail.
+
+proc dbg::setServerPort {port} {
+ variable serverSocket
+ variable serverPort
+
+ # If the current port and the requested port are identical, just
+ # return 1, indicating the port is available.
+
+ if {($serverSocket != -1) && ($serverPort == $port)} {
+ return 1
+ }
+
+ # Close the port if it has been opened.
+
+ dbg::closeServerSocket
+
+ if {$port == "random"} {
+ set result 1
+ set port 16999
+ while {$result != 0} {
+ incr port
+ set result [catch \
+ {socket -server ::dbg::HandleConnect $port} socket]
+ }
+ } else {
+ set result [catch \
+ {socket -server ::dbg::HandleConnect $port} socket]
+
+ puts "start ::server -> $result"
+ }
+
+
+ if {$result == 0} {
+ set serverPort $port
+ set serverSocket $socket
+ }
+
+ return [expr {!$result}]
+}
+
+# dbg::getServerPortStatus --
+#
+# This function returns status information about the connection
+# betwen the debugger and the debugged app. The return is a
+# list of appState & serverPort.
+#
+# Arguments:
+# None.
+#
+# Results:
+# A Tcl list
+
+proc dbg::getServerPortStatus {} {
+ variable serverPort
+ variable serverSocket
+ variable nubSocket
+ variable appHost
+
+ if {$serverSocket == -1} {
+ set status "Not connected"
+ set listenPort "n/a"
+ } else {
+ set status "Listening"
+ set listenPort "$serverPort (on [info hostname])"
+ }
+
+ if {$nubSocket != -1} {
+ set status "Connected"
+ set sockname [fconfigure $nubSocket -sockname]
+ set peername [fconfigure $nubSocket -peername]
+ } else {
+ set sockname "n/a"
+ set peername "n/a"
+ }
+
+ return [list $status $listenPort $sockname $peername]
+}
+
+# dbg::closeServerSocket --
+#
+# Close the server socket so the debugger is no longer listening
+# on the open port.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc dbg::closeServerSocket {} {
+ variable serverSocket
+ if {$serverSocket != -1} {
+ close $serverSocket
+ set serverSocket -1
+ }
+ return
+}
+
+# dbg::quit --
+#
+# Clean up the debugger engine. Kills the background app if it
+# is still running and shuts down the server socket. It also
+# cleans up all of the debugger state.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc dbg::quit {} {
+ variable appState
+ variable tempBreakpoint
+
+ if {$appState != "dead"} {
+ catch {dbg::kill}
+ }
+ dbg::closeServerSocket
+ break::Release all
+ set tempBreakpoint {}
+ blk::release all
+ return
+}
+
+# dbg::HandleClientExit --
+#
+# This function is called when the nub terminates in order to clean up
+# various aspects of the debugger state.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None. Removes any variable traces, changes the state to dead,
+# and generates an "exit" event.
+
+proc dbg::HandleClientExit {} {
+ variable nubSocket
+ variable appState
+ variable appPid
+ variable tempBreakpoint
+
+ # Release all of the variable breakpoints.
+
+ break::Release [break::GetVarBreakpoints]
+
+
+ # Release all of the dynamic blocks and breakpoints. We
+ # also need to mark all instrumented blocks as uninstrumented.
+
+ if {$tempBreakpoint != ""} {
+ break::Release $tempBreakpoint
+ set tempBreakpoint {}
+ }
+ foreach bp [break::GetLineBreakpoints] {
+ set block [loc::getBlock [break::getLocation $bp]]
+ if {[blk::isDynamic $block]} {
+ break::Release $bp
+ }
+ }
+
+ set tempBreakpoint {}
+
+ blk::release dynamic
+ blk::unmarkInstrumented
+
+ # Close the connection to the client.
+
+ close $nubSocket
+ set nubSocket -1
+ set appState "dead"
+ set appPid -1
+
+ DeliverEvent exit
+ return
+}
+
+# dbg::HandleConnect --
+#
+# Handle incoming connect requests from the nub. If there is no
+# other nub currently connected, creates a file event handler
+# to watch for events generated by the nub.
+#
+# Arguments:
+# sock Incoming connection socket.
+# host Name of nub host.
+# port Incoming connection port.
+#
+# Results:
+# None.
+
+proc dbg::HandleConnect {sock host port} {
+ variable nubSocket
+ variable appState
+
+
+ if {$nubSocket != -1} {
+ puts "close nubSocket!"
+ close $sock
+ } else {
+ puts "appState running!"
+
+ set nubSocket $sock
+ set appState running
+ fconfigure $sock -translation binary -encoding utf-8
+ fileevent $sock readable ::dbg::HandleNubEvent
+
+ # Close the server socket
+ dbg::closeServerSocket
+ }
+ return
+}
+
+# dbg::SendMessage --
+#
+# Transmit a list of strings to the nub.
+#
+# Arguments:
+# args Strings that will be turned into a list to send.
+#
+# Results:
+# None.
+
+proc dbg::SendMessage {args} {
+ variable nubSocket
+
+ puts $nubSocket [string length $args]
+ puts -nonewline $nubSocket $args
+ flush $nubSocket
+ #Log message {sent: len=[string length $args] '$args'}
+ return
+}
+
+# dbg::GetMessage --
+#
+# Wait until a message is received from the nub.
+#
+# Arguments:
+# None.
+#
+# Results:
+# Returns the message that was received, or {} if the connection
+# was closed.
+
+proc dbg::GetMessage {} {
+ variable nubSocket
+
+ set bytes [gets $nubSocket]
+# Log message {reading $bytes bytes}
+ if { $bytes == "" } {
+ return ""
+ }
+ set msg [read $nubSocket $bytes]
+# Log message {got: '$msg'}
+ return $msg
+}
+
+# dbg::SendAsync --
+#
+# Send the given script to be evaluated in the nub without
+# waiting for a result.
+#
+# Arguments:
+# args The script to be evaluated.
+#
+# Results:
+# None.
+
+proc dbg::SendAsync {args} {
+ SendMessage "SEND" 0 $args
+ return
+}
+
+# dbg::Send --
+#
+# Send the given script to be evaluated in the nub. The
+# debugger enters a limited event loop until the result of
+# the evaluation is received. This call should only be used
+# for scripts that are expected to return quickly and cannot
+# be done in a more asynchronous fashion.
+#
+# Arguments:
+# args The script to be evaluated.
+#
+# Results:
+# Returns the result of evaluating the script in the nub,
+# including any errors that may result.
+
+proc dbg::Send {args} {
+ SendMessage "SEND" 1 $args
+ while {1} {
+ set msg [GetMessage]
+ if {$msg == ""} {
+ return
+ }
+ switch -- [lindex $msg 0] {
+ RESULT { # Result of SEND message
+ return [lindex $msg 1]
+ }
+ ERROR { # Error generated by SEND
+ return -code [lindex $msg 2] -errorcode [lindex $msg 3] \
+ -errorinfo [lindex $msg 4] [lindex $msg 1]
+ }
+ default { # Looks like a bug to me
+ error "Unexpected message waiting for reply: $msg"
+ }
+ }
+ }
+}
+
+
+# dbg::dumpStack --
+#
+# Fetch global and local variable values
+# whenever the debugging session stopped.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc dbg::dumpStack {} {
+ set stkList [dbg::getStack]
+ set end [llength $stkList]
+
+ set stackData {}
+ #TODO: add more builtin variable here
+ set exludedvars {auto_path auto_index env tcl_patchLevel \
+ tcl_version tcl_library tcl_platform tcl_pkgPath \
+ tcl_rcFileName tcl_interactive argc argv argv0}
+
+ for {set i [expr {$end - 1}]} {$i >= 0} {incr i -1} {
+ set stk [lindex $stkList $i]
+ set level [lindex $stk 0]
+ set loc [lindex $stk 1]
+ set type [lindex $stk 2]
+ set lname [lindex $stk 3]
+ set args [lindex $stk 4]
+
+ set aVars {}
+ set infoVars {}
+ set realVars [dbg::getVariables $level]
+ if {$realVars != ""} {
+ foreach pair $realVars {
+ set oname [lindex $pair 0]
+ set type [lindex $pair 1]
+
+ if {[lsearch -exact $exludedvars $oname] >= 0} {
+ continue
+ }
+
+ if { $type == "a" } {
+ lappend aVars $oname
+ }
+ lappend infoVars $oname
+ }
+ }
+
+ set varstring {}
+ if {$infoVars != ""} {
+ foreach info [dbg::getVar $level -1 $infoVars] {
+ set oname [lindex $info 0]
+ set type [lindex $info 1]
+ set value [lindex $info 2]
+ #set mname [code::mangle $oname]
+ if {$value == ""} {
+ set value " "
+ }
+ #errorInfo errorCode
+ lappend varstring "\"$oname\": \"$value\""
+ }
+
+ }
+
+ if {$lname == ""} {
+ continue
+ }
+
+ set strVarsValue ""
+ if {$varstring != ""} {
+ set strVarsValue [join $varstring ",\n"]
+ }
+
+ set line "\""
+ append line $lname
+ append line "\":\n{$strVarsValue}"
+ lappend stackData $line
+
+ }
+
+ set datastring [join $stackData ",\n"]
+ set message "{\n \"command\": \"stack\",\n \"data\":\n{"
+ append message "$datastring \n}\n}"
+ DeliverEvent stackinfo $message
+
+ return
+}
+
+
+# dbg::HandleNubEvent --
+#
+# This function is called whenever the nub generates an event on
+# the nub socket. It will invoke HandleEvent to actually
+# process the event.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc dbg::HandleNubEvent {} {
+ variable nubSocket
+ variable currentPC
+ variable appState
+ variable stack
+ variable currentLevel
+ variable tempBreakpoint
+
+
+ set result [catch {
+
+ # Get the next message from the nub
+ set msg [GetMessage]
+ set command [lindex $msg 0]
+
+ # If the nub closed the connection, generate an "exit" event.
+ if {[eof $nubSocket]} {
+ puts "nub closed the connection"
+ HandleClientExit
+ return
+ }
+
+ switch -- [lindex $msg 0] {
+ HELLO {
+ if {[llength $msg] == 3} {
+ set project REMOTE
+ } else {
+ set project [lindex $msg 3]
+ }
+ dbg::InitializeNub [lindex $msg 1] [lindex $msg 2] $project
+ }
+ ERROR {
+ error "Got an ERROR from an asyncronous SEND: $msg"
+ }
+ RESULT { # Result of SEND message, should not happen
+ error "Got SEND result outside of call to dbg::Send; $msg"
+ }
+ BREAK {
+
+ #Log timing {HandleNubEvent BREAK}
+
+ set appState "stopped"
+ set stack [lindex $msg 1]
+ set frame [lindex $stack end]
+ set currentPC [lindex $frame 1]
+ set currentLevel [lindex $frame 0]
+
+ set blk [loc::getBlock $currentPC]
+ set line [loc::getLine $currentPC]
+ #set range [loc::getRange $currentPC]
+ set file [blk::getFile $blk]
+
+ if {$line != ""} {
+ DeliverEvent linebreak $file $line
+ }
+
+ dbg::dumpStack
+
+ # Remove any current temporary breakpoint
+ if {$tempBreakpoint != ""} {
+ dbg::removeBreakpoint $tempBreakpoint
+ set tempBreakpoint {}
+ }
+
+# If coverage is on, retrieve and store coverage data
+# if {$::coverage::coverageEnabled} {
+# coverage::tabulateCoverage [lindex $msg 2]
+# }
+
+ # Break up args and reform it as a valid list so we can safely
+ # pass it through eval.
+ set newList {}
+ foreach arg [lindex $msg 4] {
+ lappend newList $arg
+ }
+ eval {DeliverEvent [lindex $msg 3]} $newList
+ }
+ INSTRUMENT {
+ SendAsync DbgNub_InstrumentReply [dbg::Instrument [lindex $msg 1] \
+ [lindex $msg 2]]
+ }
+ PROCBODY {
+ set body [dbg::getProcBody [lindex $msg 1]]
+ SendAsync array set DbgNub [list body $body state running]
+ }
+ UNSET { # A variable was unset so clean up the trace
+ set handle [lindex $msg 1]
+ break::Release [break::GetVarBreakpoints $handle]
+ }
+ default { # Looks like a bug to me
+ #Log error {Unexpected message: $msg}
+ puts "Unexpected message: $msg"
+ }
+ }
+ } msg]
+
+ if {$result == 1} {
+ #Log error {Caught error in dbg::HandleNubEvent: $msg at \n$::errorInfo}
+ puts "Error $msg"
+ }
+ return
+}
+
+
+# dbg::ignoreError --
+#
+# Indicates that the debugger should suppress the current error
+# being propagated by the nub.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc dbg::ignoreError {} {
+ variable appState
+
+ if {$appState != "stopped"} {
+ #error "dbg::step called with an app that is not stopped."
+ puts "dbg::step called with an app that is not stopped."
+ return
+ }
+
+ SendAsync DbgNub_IgnoreError
+ return
+}
+
+
+# dbg::Instrument --
+#
+# Instrument a new block of code. Creates a block to contain the
+# code and returns the newly instrumented script.
+#
+# Arguments:
+# file File that contains script if this is being
+# called because of "source", otherwise {}.
+# script Script to be instrumented.
+#
+# Results:
+# Returns the instrumented code or "" if the instrumentation failed.
+
+proc dbg::Instrument {file script} {
+
+ # Get a block for the new code.
+ # puts "dbg::Instrument: $file"
+
+ set block [blk::makeBlock $file]
+
+ #puts "instrument start"
+
+ # Send the debugger a message when the instrumentation
+ # begins and ends.
+
+ DeliverEvent instrument start $block
+ set alreadyInstrumented [blk::isInstrumented $block]
+
+ # Generate the instrumented script.
+
+ set icode [blk::Instrument $block $script]
+
+ # Ensure that all breakpoints are valid.
+
+ dbg::validateBreakpoints $file $block
+
+ if {$icode != "" && !$alreadyInstrumented} {
+ # If the instrumentation succeeded and the block was not previously
+ # instrumented (e.g. re-sourcing), create any enabled breakpoints.
+
+ foreach breakpoint [break::GetLineBreakpoints \
+ [loc::makeLocation $block {}]] {
+ if {[break::getState $breakpoint] == "enabled"} {
+ SendAsync DbgNub_AddBreakpoint "line" \
+ [break::getLocation $breakpoint] \
+ [break::getTest $breakpoint]
+ }
+ }
+ }
+
+ # puts "instrument end"
+
+ DeliverEvent instrument end $block
+ return $icode
+}
+
+# dbg::Log --
+#
+# Log a debugging message.
+#
+# Arguments:
+# type Type of message to log
+# message Message string. This string is substituted in
+# the calling context.
+#
+# Results:
+# None.
+
+proc dbg::Log {type message} {
+ variable logFilter
+ variable debug
+
+ if {!$debug || [lsearch -exact $logFilter $type] == -1} {
+ return
+ }
+ puts $::dbg::logFile "LOG($type,[clock clicks]): [uplevel 1 [list subst $message]]"
+ update idletasks
+ return
+}
+
+# dbg::InitializeNub --
+#
+# Initialize the client process by sending the nub library script
+# to the client process.
+#
+# Arguments:
+# nubVersion The nub loader version.
+# tclVersion The tcl library version.
+# clientData The clientData passed to debugger_init.
+#
+# Results:
+# None.
+
+proc dbg::InitializeNub {nubVersion tclVersion clientData} {
+ variable appHost
+ variable appPid
+ variable libDir
+ variable appState
+ variable appVersion
+ variable nubSocket
+
+ # Load the nub into the client application. Note that we are getting
+ # the nub from the current working directory because we assume it is
+ # going to be packaged into the debugger executable.
+
+ #set fd [open $::debugger::libdir/nub.tcl r]
+ set fd [open nub.tcl r]
+ set nubScript [read $fd]
+ close $fd
+
+ # If we are talking to an older version of Tcl, change the channel
+ # encoding to iso8859-1 to avoid sending multibyte characters.
+
+ if {$tclVersion < 8.1} {
+ fconfigure $nubSocket -encoding iso8859-1
+ }
+
+ SendMessage NUB $nubScript
+
+ # Fetch some information about the client and set up some
+ # initial state.
+
+ set appPid [Send pid]
+ set appState "stopped"
+ set appVersion $tclVersion
+ set appHost [Send info hostname]
+
+ dbg::initInstrument
+
+ # Begin coverage if it is enabled.
+
+# if {$::coverage::coverageEnabled} {
+# SendAsync DbgNub_BeginCoverage
+# }
+
+ # Configure the instrumentor to know what version of Tcl
+ # we are debugging.
+
+ instrument::initialize $appVersion
+
+ DeliverEvent attach $clientData
+
+ # puts "dbg::InitializeNub sucessfully."
+
+ return
+}
+
+# dbg::initInstrument --
+#
+# This command will communicate with the client application to
+# initialize various preference flags. The flags being set are:
+#
+# DbgNub(dynProc) If true, then instrument dynamic procs.
+# DbgNub(includeFiles) A list of files to be instrumented.
+# DbgNub(excludeFiles) A list of files not to be instrumented.
+# Exclusion takes precedence over inclusion.
+# DbgNub(autoLoad) If true, instrument scripts sourced
+# during auto_loading or package requires.
+# DbgNub(errorAction) If 0, propagate errors. If 1, stop on
+# uncaught errors. If 2, stop on all errors.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc dbg::initInstrument {} {
+ puts "dbg::initInstrument: $dbg::appState"
+
+ if {$dbg::appState != "dead"} {
+
+ SendAsync set DbgNub(dynProc) 1
+ SendAsync set DbgNub(includeFiles) 1
+ SendAsync set DbgNub(excludeFiles) 1
+ SendAsync set DbgNub(autoLoad) 1
+ SendAsync set DbgNub(errorAction) 1
+
+ }
+ return
+}
+
+# dbg::getAppVersion --
+#
+# Return the tcl_version of the running app.
+#
+# Arguments:
+# None.
+#
+# Results:
+# Return the tcl_version of the running app.
+
+proc dbg::getAppVersion {} {
+ return $dbg::appVersion
+}
+
+# dbg::isLocalhost --
+#
+# Determine if the nub is running on the same host as the debugger.
+#
+# Arguments:
+# None.
+#
+# Results:
+# Boolean, true if the nub and debugger are on the same machine.
+
+proc dbg::isLocalhost {} {
+ variable appState
+ variable appHost
+
+ if {$appState == "dead"} {
+ return 1
+ }
+ return [expr {[string compare $appHost [info hostname]] == 0}]
+}
+
+# dbg::SetState --
+#
+# Change the debugger state.
+#
+# Arguments:
+# state The state changed to.
+#
+# Results:
+# None.
+
+proc dbg::SetState {state} {
+ variable appState
+ set appState $state
+}
+
+
+
--- /dev/null
+# The Tcl debugger for Speare code editor.
+# Copyright (c) 1998-2000 Ajuba Solutions
+# Copyright (c) 2019 sevenuc.com. All rights reserved.
+#
+# THIS FILE IS PART OF SPEARE CODE EDITOR. WITHOUT THE
+# WRITTEN PERMISSION OF THE AUTHOR THIS FILE MAY NOT
+# BE USED FOR ANY COMMERCIAL PRODUCT.
+#
+# More info:
+# http://sevenuc.com/en/Speare.html
+# Contact:
+# Sevenuc support <info@sevenuc.com>
+# Issue report and requests pull:
+# https://github.com/chengdu/Speare
+
+
+# The inner port used by the debugger
+set port 2576
+
+# The communication port between the debugger and Speare code editor
+set svcPort 9999
+
+# The location of Tcl interpreter
+set tclsh "/Users/yeung/bin/tcl/bin/tclsh8.5"
+
+# The source code directory of the Tcl debugger
+set libDir "/Users/yeung/Desktop/TclDebugger/src"
+
+# The source code directory of the test project
+set startDir "/Users/yeung/Desktop/test"
+
+set clientsock -1
+
+
+# initDbg --
+#
+# Initialize the debugger
+# This routine must be called from within the src directory.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc initDbg {} {
+ variable libDir
+
+ set blk::blockCounter 0
+ dbg::initialize $libDir
+
+ #Register events sent from the engine.
+ dbg::register stackinfo {stackinfoHandler}
+ dbg::register linebreak {linebreakHandler}
+ dbg::register varbreak {varbreakHandler}
+ dbg::register userbreak {userbreakHandler}
+ dbg::register cmdresult {cmdresultHandler}
+ dbg::register exit {exitHandler}
+ dbg::register error {errorHandler}
+ dbg::register result {resultHandler}
+ dbg::register attach {attachHandler}
+ dbg::register instrument {instrumentHandler}
+ # Register the error handler for errors during instrumentation.
+ set instrument::errorHandler instrumentErrorHandler
+
+ return
+}
+
+
+proc attachHandler { clientData } {
+ #dbg::changeState running
+ #puts "attachHandler $clientData"
+}
+
+
+# resultHandler --
+#
+# Callback executed when the nub sends a result message.
+# Notify the Eval Window of the result and update the
+# variable windows in case the eval changed the var frames.
+#
+# Arguments:
+# code A standard Tcl result code for the evaled cmd.
+# result A value od the result for the evaled cmd.
+# errCode A standard Tcl errorCode for the evaled cmd.
+# errInfo A standard Tcl errorInfo for the evaled cmd.
+#
+# Results:
+# None.
+
+proc resultHandler {id code result errCode errInfo} {
+ puts "resultHandler $result"
+ return
+}
+
+
+# varbreakHandler --
+#
+# Update the debugger when a VBP is fired. Store in the
+# GUI that the break occured because of a VBP so the
+# codeBar will draw the correct icon.
+#
+# Arguments:
+# var The var that cused the break.
+# type The type of operation performed in the var (w,u,r)
+#
+# Results:
+# None.
+
+proc varbreakHandler {var type} {
+ #dbg::stoppedHandler var
+ puts "varbreakHandler $var"
+ return
+}
+
+
+# stackinfoHandler --
+#
+# Send the variable values to Speare code editor
+# whenever the app stopped.
+#
+# Arguments:
+# stackdata The global and local variable values.
+#
+# Results:
+# None.
+proc stackinfoHandler { stackdata } {
+ variable clientsock
+ if {$stackdata == ""} {
+ return
+ }
+
+ puts -nonewline $clientsock "\r\n"
+ puts -nonewline $clientsock $stackdata
+ puts -nonewline $clientsock "\r\n"
+ return
+}
+
+
+# linebreakHandler --
+#
+# Update the debugger when a LBP is fired. Store in the
+# GUI that the break occured because of a LBP so the
+# codeBar will draw the correct icon.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc linebreakHandler {args} {
+ variable clientsock
+
+ set file [lindex $args 0]
+ set line [lindex $args 1]
+
+ if {$file == "" || $line == ""} {
+ return
+ }
+
+ puts $clientsock "\r\n{\"command\": \"paused\", \"file\": \"$file\", \"line\": $line}"
+
+ return
+}
+
+
+# cmdresultHandler --
+#
+# Update the display when the debugger stops at the end of a
+# command with the result.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc cmdresultHandler {args} {
+ #dbg::stoppedHandler cmdresult
+ #puts "cmdresultHandler $args"
+ return
+}
+
+# userbreakHandler --
+#
+# This handles a users call to "debugger_break" it is
+# handled just like a line breakpoint - except that we
+# also post a dialog box that denotes this type of break.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc userbreakHandler {args} {
+ eval linebreakHandler $args
+
+ set str [lindex $args 0]
+ if {$str == ""} {
+ puts "Script called debugger_break"
+ } else {
+ puts $str
+ }
+
+ return
+}
+
+
+# stoppedHandler --
+#
+# Update the debugger when the app stops.
+#
+# Arguments:
+# breakType Store the reason for the break (result, line, var...)
+#
+# Results:
+# None.
+
+proc stoppedHandler {breakType} {
+ #dbg::changeState stopped
+ #dbg::Log timing {dbg::stoppedHandler $breakType}
+
+ return
+}
+
+
+# exitHandler --
+#
+# Callback executed when the nub sends an exit message.
+# Re-initialize the state of the Debugger and clear all
+# sub-windows.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc exitHandler {} {
+ variable clientsock
+
+ #dbg::changeState dead
+ #puts "end of script..."
+ puts $clientsock "\r\nexit\r\n"
+ exit 1
+
+ return
+}
+
+# errorHandler --
+#
+# Show the error message in the error window.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc errorHandler {errMsg errStk errCode uncaught} {
+ variable uncaughtError
+
+ stoppedHandler error
+ #set uncaughtError $uncaught
+ set level [dbg::getLevel]
+ set pc [dbg::getPC]
+ puts $level $pc $errMsg $errStk $errCode
+ exit 1
+
+ return
+}
+
+
+proc instrumentHandler {status block} {
+ #puts "instrumentHandler $status"
+ if {$status == "end"} {
+ dbg::SetState "stopped"
+ }
+}
+
+
+proc instrumentErrorHandler {} {
+ puts "instrument error"
+ exit 1
+}
+
+
+# quitDbg --
+#
+# Stop debugging the application and unregister the eventProcs
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc quitDbg {} {
+ catch {dbg::quit; after 100}
+
+ exit 1
+ return
+}
+
+
+# launchDbg --
+#
+# Start the both the debugger and the application to debug.
+# Set up initial communication.
+#
+# Arguments:
+# app Interpreter in which to run scriptFile.
+# port Number of port on which to communicate.
+# scriptFile File to debug.
+# verbose Boolean that decides whether to log activity.
+# startDir the directory where the client program should be
+# started.
+
+proc launchDbg {app startDir scriptFile} {
+ dbg::setServerPort random
+
+ initDbg
+
+ #set result [uplevel 1 $scriptFile]
+
+ # Start the application and wait for the "attach" event.
+ dbg::start $app $startDir $scriptFile {} REMOTE
+ waitForApp
+
+ return
+}
+
+
+# waitForApp --
+#
+# Call this proc after dbg::step, dbg::run, dbg::evaluate. Returns
+# when the global variable Dbg_AppStopped is set by the breakProc
+# or exitProc procedures.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc waitForApp {} {
+ global Dbg_AppStopped
+
+ vwait Dbg_AppStopped
+ set ret $Dbg_AppStopped
+ set Dbg_AppStopped "run"
+ return $ret
+}
+
+
+# handleBreakpoint --
+#
+# Call this proc when debugger received a breakpoint command.
+#
+# Arguments:
+# sub The subcommand.
+# filepath The path of the script the breakpoint located in
+# line Line number of the breakpoint
+#
+# Results:
+# None.
+# breakpoint + [add|remove|enable|disnable] + file + line
+proc handleBreakpoint {sub filepath line} {
+ set block [blk::makeBlock $filepath]
+ set loc [loc::makeLocation $block $line]
+ if { $sub == "add"} {
+ dbg::addLineBreakpoint $loc
+ return
+ }
+ set bps [dbg::getLineBreakpoints $loc]
+ foreach bp $bps {
+ if { $sub == "remove"} {
+ dbg::removeBreakpoint $bp
+ }elseif { $sub == "enable"} {
+ dbg::enableBreakpoint $bp
+ }elseif { $sub == "disable"} {
+ dbg::disableBreakpoint $bp
+ }
+ }
+ return
+}
+
+
+# doService --
+#
+# Call this proc when debugger received a command
+# from Speare code editor
+#
+# Arguments:
+# sock The socket connection between debugger and Speare.
+# msg The command sent from Speare, separated by tab
+#
+# Results:
+# None.
+proc doService {sock msg} {
+ variable tclsh
+ variable startDir
+
+ # init + filepath
+ # step + [into|out|over|result]
+ # run
+ # breakpoint + [add|remove|enable|disnable] + file + line
+ # evaluate + expression
+ # quit
+
+ #puts "received: $msg"
+
+ set lines [split $msg "\t"]
+ if { [llength $lines ] < 2 } {
+ switch -- $msg {
+ run {
+ dbg::run
+ }
+ quit {
+ dbg::quit
+ }
+ }
+ return
+ }
+
+
+ set command [lindex $lines 0]
+ #puts "command: $command"
+ switch -- $command {
+ init {
+ set scriptFile [lindex $lines 1]
+ launchDbg $tclsh $startDir $scriptFile
+ }
+ step {
+ set sub [lindex $lines 1]
+ switch -- $sub {
+ into { dbg::step }
+ out { dbg::step out }
+ over { dbg::step over }
+ result { dbg::step cmdresult }
+ any { dbg::step any }
+ }
+ }
+ breakpoint {
+ if {[llength $lines] != 4} {
+ return;
+ }
+ set sub [lindex $lines 1]
+ set file [lindex $lines 2]
+ set line [lindex $lines 3]
+ handleBreakpoint $sub $file $line
+ }
+ evaluate {
+ set expression [lindex $lines 1]
+ dbg::evaluate 1 $expression
+ }
+ interrupt {
+ dbg::interrupt
+ }
+ }
+
+ return
+}
+
+# doService --
+#
+# Handles the command sent
+# from Speare code editor
+#
+# Arguments:
+# sock The socket connection between debugger and Speare.
+#
+# Results:
+# None.
+proc svcHandler {sock} {
+ set l [gets $sock] ;# get the client packet
+ if {[eof $sock]} { ;# client gone or finished
+ puts "*** client socket closed."
+ close $sock;# release the servers client channel
+ exit 0
+ } else {
+ doService $sock $l
+ }
+ return
+}
+
+
+# Accept-Connection handler for Speare Debug Server.
+# called When client makes a connection to the debugger
+# Its passed the channel we're to communicate with the client on,
+# The address of the client and the port we're using
+#
+# Setup a handler for (incoming) communication on the client channel
+proc accept {sock addr port} {
+ variable clientsock
+ set clientsock $sock
+
+ # Setup handler for future communication on client socket
+ fileevent $sock readable [list svcHandler $sock]
+ fconfigure $sock -translation binary -encoding utf-8
+
+ # Note we've accepted a connection from Speare code editor
+ puts "Accept from [fconfigure $sock -peername]"
+
+ # Read client input in lines, disable blocking I/O
+ fconfigure $sock -buffering line -blocking 0
+
+ # Send Acceptance string to client
+ puts $sock "$addr:$port, You are connected to the Tcl debug server."
+ puts $sock "It is now [exec date]"
+
+ # log the connection
+ puts "Accepted connection from $addr at [exec date]."
+
+ return
+}
+
+# setup search path
+lappend ::auto_path [file dirname [file normalize [info script]]]
+
+# load debugger sources
+foreach file {
+ dbg.tcl block.tcl break.tcl instrument.tcl location.tcl util.tcl
+} {
+ source $file
+}
+
+puts "debug server listen on: $svcPort"
+
+# Create a server socket on port $svcPort.
+# Call proc accept when a client attempts a connection.
+
+socket -server accept $svcPort
+vwait events; # handle events till variable events is set
+
+
+
--- /dev/null
+# The Tcl debugger for Speare code editor.
+# Copyright (c) 1998-2000 Ajuba Solutions
+# Copyright (c) 2019 sevenuc.com. All rights reserved.
+#
+# THIS FILE IS PART OF SPEARE CODE EDITOR. WITHOUT THE
+# WRITTEN PERMISSION OF THE AUTHOR THIS FILE MAY NOT
+# BE USED FOR ANY COMMERCIAL PRODUCT.
+#
+# More info:
+# http://sevenuc.com/en/Speare.html
+# Contact:
+# Sevenuc support <info@sevenuc.com>
+# Issue report and requests pull:
+# https://github.com/chengdu/Speare
+
+
+
+package require parser
+
+package provide instrument 1.0
+namespace eval instrument {
+
+ namespace export addExtension addCommand
+
+ # Stores the array of extensions that the instrumentor is using.
+
+ variable extensions
+ array set extensions {
+ incrTcl 0
+ tclx 0
+ expect 0
+ }
+
+ # Stores the block currently being instrumented.
+
+ variable block {}
+
+ # Stores the script currently being instrumented.
+
+ variable script {}
+
+ # List of line numbers in current script that contain the
+ # start of an instrumented line of code.
+
+ variable lines
+
+ # Stores the instrumented code while it is being generated. The
+ # resultStack contains a list of partially completed result strings.
+
+ variable result {}
+ variable cmdInfoStack {}
+ variable suppress 0
+
+ # The anchor records the range within the script being instrumented that
+ # should be included in the next string that is appended to the result.
+ # The anchorStart indicates the byte offset of the first character in the
+ # range. The anchorEnd is a range whose last character is the end of
+ # the anchor range.
+
+ variable anchorStart 0
+ variable anchorEnd [list 0 0]
+
+ # Stores the location associated with the current command being
+ # instrumented.
+
+ variable location {}
+
+ # This flag acts as a lock for this file because the instrumenter is
+ # not reentrant. It is set to 1 whenever the instrumentor is in use.
+
+ variable busy 0
+
+ # This variable can be sent to an error handling procedure that gets passed
+ # the script and the current range whenever an error occurs. The errorCode
+ # global variable will contain information about the error. If this
+ # procedure returns 1, the instrumenter will attempt to continue.
+ # Otherwise the instrumenter will generate an error.
+
+ variable errorHandler {}
+
+ # Records if the current statement is part of a command substitution.
+
+ variable isSubcommand 0
+
+ # The contextStack is a list used to keep track of incrTcl state.
+
+ variable contextStack {global}
+
+ # This table describes the instrumentation actions that need to be
+ # take for each of the core Tcl commands. The first column is that
+ # name of the command to instrument. The second column is the earliest
+ # Tcl version that the rule should be applied to. The third column
+ # is a command prefix that should be invoked to handle the command.
+ # The list of tokens and the current token index will be appended to
+ # the command.
+
+ variable coreTclCmds {
+ after 7.5 {parseOption {
+ {cancel {parseCommand}}
+ {idle {parseSimpleArgs 1 1 {parseBody}}}
+ {info {parseCommand}}
+ } {parseSimpleArgs 2 2 {parseWord parseBody}}}
+ catch 7.3 {parseSimpleArgs 1 3 {parseBody parseWord}}
+ eval 7.3 {parseSimpleArgs 1 1 {parseBody}}
+ expr 7.3 {parseSimpleArgs 1 1 {parseExpr}}
+ for 7.3 {parseSimpleArgs 4 4 {parseBody parseExpr parseBody \
+ parseBody}}
+ foreach 7.3 {parseTail 3 {parseWord parseBody}}
+ if 7.3 {parseIfCmd}
+ fcopy 8.0 {parseSimpleArgs 2 6 {
+ parseWord parseWord
+ {parseSwitches 0 {
+ {-command parseBody}
+ {-size parseWord}
+ } {parseWord}}
+ }
+ }
+ fileevent 7.5 {parseSimpleArgs 2 3 {parseWord parseWord parseBody}}
+
+ namespace 8.0 {parseOption {
+ {eval {wrapCommand DbgNub_NamespaceEval 2 \
+ {parseWord parseBody}}}
+ } {parseCommand}}
+
+ package 7.5 {parseOption {
+ {ifneeded {parseSimpleArgs 2 3 \
+ {parseWord parseWord parseBody}}}
+ } {parseCommand}}
+ proc 7.3 {parseSimpleArgs 3 3 {parseWord parseWord parseBody}}
+ return 7.3 {parseReturnCmd}
+ switch 7.3 {parseSwitchCmd}
+ time 7.3 {parseSimpleArgs 1 2 {parseBody parseWord}}
+ while 7.3 {parseSimpleArgs 2 2 {parseExpr parseBody}}
+
+ apply 8.5 {parseApplyCmd}
+
+ chan 8.5 {parseOption {
+ {copy {parseSimpleArgs 2 6 {
+ parseWord parseWord
+ {parseSwitches 0 {
+ {-command parseBody}
+ {-size parseWord}
+ } {parseWord}}
+ }
+ }}
+ {event {parseSimpleArgs 2 3 {parseWord parseWord parseBody}}}
+ } {parseCommand}}
+
+ dict 8.5 {parseOption {
+
+ {for {parseSimpleArgs 3 3 {parseWord parseWord parseBody}}}
+ {map {parseSimpleArgs 3 3 {parseWord parseWord parseBody}}}
+ {update {parseTail 4 {parseWord parseBody}}}
+ {with {parseTail 2 {parseWord parseBody}}}
+
+ } {parseCommand}}
+
+ lmap 8.6 {parseTail 3 {parseWord parseBody}}
+
+ try 8.6 {parseTryCmd}
+
+ }
+
+ variable incrTclCmds {
+ body 2.0 {wrapCommand DbgNub_WrapItclBody 3 \
+ {parseWord parseWord parseItclBody}}
+ class 2.0 {parseSimpleArgs 2 2 \
+ {parseWord {parseBody parseIncr22Class}}}
+ class 3.0 {parseItclClass}
+ configbody 2.0 {parseSimpleArgs 2 2 {parseWord parseItclBody}}
+ namespace 2.1 {parseOption {
+ {all parseCommand}
+ {children parseCommand}
+ {parent parseCommand}
+ {qualifiers parseCommand}
+ {tail parseCommand}
+ } {parseTail 2 {parseWord parseIncr22NSBody}}}
+ namespace 3.0 {parseOption {
+ {eval {wrapCommand DbgNub_NamespaceEval 2 \
+ {parseWord parseBody}}}
+ } {parseCommand}}
+ constructor 3.0 {parseCommand}
+ destructor 3.0 {parseCommand}
+ method 3.0 {parseCommand}
+ private 3.0 {parseCommand}
+ protected 3.0 {parseCommand}
+ public 3.0 {parseCommand}
+ variable 3.0 {parseCommand}
+
+ itcl::body 3.0 {wrapCommand DbgNub_WrapItclBody 3 \
+ {parseWord parseWord parseItclBody}}
+ itcl::class 3.0 {parseItclClass}
+ itcl::configbody 3.0 {parseSimpleArgs 2 2 {parseWord parseItclBody}}
+ }
+
+ variable tclxCmds {
+ commandloop 8.0 {parseSwitches 1 {
+ -async
+ {-interactive parseWord}
+ {-prompt1 parseBody}
+ {-prompt2 parseBody}
+ {-endcommand parseBody}
+ } {}}
+ for_array_keys 8.0 {parseSimpleArgs 3 3 \
+ {parseWord parseWord parseBody}}
+ for_file 8.0 {parseSimpleArgs 3 3 \
+ {parseWord parseWord parseBody}}
+ for_recursive_glob 8.0 {parseSimpleArgs 4 4 \
+ {parseWord parseWord parseWord parseBody}}
+ loop 8.0 {parseSimpleArgs 4 5 {parseWord parseExpr \
+ parseExpr {parseTail 1 \
+ {parseExpr parseBody}}}}
+ try_eval 8.0 {parseSimpleArgs 2 3 {parseBody}}
+ signal 8.0 {parseSwitches 1 {-restart} {
+ parseSimpleArgs 2 3 \
+ {parseWord parseWord parseBody}}
+ }
+ }
+
+ variable expectCmds {
+ exp_exit 5.28 {parseOption {
+ {-onexit {parseSimpleArgs 1 1 {parseBody}}}
+ } parseCommand}
+ exp_interact 5.28 {parseExpect parseInteractTokens}
+ exp_trap 5.28 {parseExpTrapCmd}
+ expect 5.28 {parseExpect parseExpectTokens}
+ expect_after 5.28 {parseOption {{-info parseCommand}} \
+ {parseExpect parseExpectTokens}
+ }
+ expect_background 5.28 {parseOption {{-info parseCommand}} \
+ {parseExpect parseExpectTokens}
+ }
+ expect_before 5.28 {parseOption {{-info parseCommand}} \
+ {parseExpect parseExpectTokens}
+ }
+ expect_tty 5.28 {parseExpect parseExpectTokens}
+ expect_user 5.28 {parseExpect parseExpectTokens}
+ interact 5.28 {parseExpect parseInteractTokens}
+ trap 5.28 {parseExpTrapCmd}
+ }
+
+ variable extraCmds
+ # TODO: command prefixes - lsort -command, trace
+}
+
+# instrument::loadHandlers --
+#
+# Load the command handlers for a given version of an extension.
+#
+# Arguments:
+# extname The extension name.
+# version The version to load.
+#
+# Results:
+# None.
+
+proc instrument::loadHandlers {extname version} {
+ variable handler
+
+ foreach {name cmdVersion cmd} [set ::instrument::${extname}Cmds] {
+ if {$cmdVersion <= $version} {
+ set handler($name) $cmd
+ }
+ }
+ return
+}
+
+# instrument::initialize --
+#
+# This function is called when we start debugging a new
+# application. We pass in the Tcl version number to
+# if certain behavior should change. (Like instrumenting
+# the namespace command.)
+#
+# Arguments:
+# version The Tcl Version of the debugged application.
+#
+# Results:
+# None.
+
+proc instrument::initialize {tclVersion} {
+ variable handler
+ variable extensions
+ variable extraCmds
+
+ if {[info exists handler]} {
+ unset handler
+ }
+
+ # Expect should be initialized first in case we need to override any
+ # handlers in other extensions. Expect is always lowest priority
+ # when installing handlers.
+
+ if {$extensions(expect)} {
+ # We only support one version for now.
+ loadHandlers expect 5.28
+ }
+
+ # Initialize the Tcl core.
+
+ loadHandlers coreTcl $tclVersion
+
+ if {$extensions(incrTcl)} {
+ if {$tclVersion >= 8.0} {
+ set incrVersion 3.0
+ } else {
+ set incrVersion 2.2
+ }
+ loadHandlers incrTcl $incrVersion
+ }
+
+ if {$extensions(tclx)} {
+ # Tclx uses the same version numbers as Tcl.
+ loadHandlers tclx $tclVersion
+ }
+
+ if {[info exists extraCmds]} {
+ foreach {extra} $extraCmds {
+ set handler([lindex $extra 0]) [lindex $extra 1]
+ }
+ }
+ return
+}
+
+# instrument::extension --
+#
+# This command turns on or off the instrumentation of the
+# built-in packages.
+#
+# Arguments:
+# package One of the following pre-defined packages that
+# the instrumentor knows about. These include:
+# incr - incr Tcl (not done yet)
+# op If true add it to the list of packages we
+# instrument, else remove it.
+#
+# Results:
+# None.
+
+proc instrument::extension {package op} {
+ variable extensions
+
+ set extensions($package) $op
+ return
+}
+
+# instrument::addExtension --
+#
+# This routine must be the first command in an extension file.
+# It registers an extension and specifies the API version.
+#
+# Arguments:
+# ver The API version requested. Must be 2.0.
+# desc Description of the extension.
+#
+# Results:
+# None.
+
+proc instrument::addExtension {ver desc} {
+ if {[string compare $ver "2.0"] != 0} {
+ error "Error in $desc: Extension requested unsupported version $ver"
+ }
+ return
+}
+
+
+
+# instrument::addCommand --
+#
+# Allow an extension to add a new command handler.
+#
+# Arguments:
+# command Command to register handler for.
+# action The action to invoke in the slave interpreter
+# when this command is being instrumented.
+#
+# Results:
+# None.
+
+proc instrument::addCommand {command action} {
+ variable extraCmds
+
+ lappend extraCmds [list $command $action]
+ return
+}
+
+# instrument::Init --
+#
+# Initialize the instrumentation state for a new block.
+#
+# Arguments:
+# block The block being instrumented.
+#
+# Results:
+# None.
+
+proc instrument::Init {block} {
+ set ::instrument::block $block
+ set ::instrument::ranges {}
+ set ::instrument::script [blk::getSource $block]
+ set ::instrument::lines {}
+ set ::instrument::result {}
+ set ::instrument::anchorStart 0
+ set ::instrument::anchorEnd [list 0 0]
+ set ::instrument::location [loc::makeLocation $block 1 \
+ [parse getrange $::instrument::script]]
+ set ::instrument::locStack {}
+ return
+}
+
+# instrument::getLocation --
+#
+# Retrieve the location for the current command.
+#
+# Arguments:
+# None.
+#
+# Results:
+# Returns the location.
+
+proc instrument::getLocation {} {
+ return $::instrument::location
+}
+
+# instrument::setLocation --
+#
+# Updates the current location information to refer to the
+# specified range. Recomputes the current line number.
+#
+# Arguments:
+# range The new location range.
+#
+# Results:
+# None.
+
+proc instrument::setLocation {range} {
+ set oldRange [loc::getRange $::instrument::location]
+ set line [loc::getLine $::instrument::location]
+ if {[lindex $range 0] < [lindex $oldRange 0]} {
+ incr line -[parse countnewline $::instrument::script $range $oldRange]
+ } else {
+ incr line [parse countnewline $::instrument::script $oldRange $range]
+ }
+ set ::instrument::location \
+ [loc::makeLocation $::instrument::block $line $range]
+ return
+}
+
+# instrument::pushContext --
+#
+# Save the current command information on a stack.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc instrument::pushContext {} {
+ set ::instrument::locStack [linsert $::instrument::locStack 0 \
+ $::instrument::location]
+}
+
+# instrument::popContext --
+#
+# Restore a previously saved command context.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc instrument::popContext {} {
+ set ::instrument::location [lindex $::instrument::locStack 0]
+ set ::instrument::locStack [lrange $::instrument::locStack 1 end]
+}
+
+# instrument::setAnchor --
+#
+# Sets the anchor position emitting any pending ranges.
+#
+# Arguments:
+# range The anchor is set to the beginning of this range.
+#
+# Results:
+# None.
+
+proc instrument::setAnchor {range} {
+ Flush
+ set ::instrument::anchorStart [lindex $range 0]
+ set ::instrument::anchorEnd [list $::instrument::anchorStart 0]
+ return
+}
+
+# instrument::resetAnchor --
+#
+# This function moves the cursor back to the current anchor point
+# without emitting any text.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc instrument::resetAnchor {} {
+ set ::instrument::anchorEnd [list $::instrument::anchorStart 0]
+}
+
+# instrument::setCursor --
+#
+# Sets the cursor to the end of the specified range.
+#
+# Arguments:
+# range The range that indentifies the cursor location.
+#
+# Results:
+# None.
+
+proc instrument::setCursor {range} {
+ set ::instrument::anchorEnd $range
+ return
+}
+
+# instrument::Flush --
+#
+# Emit any pending text and advance the anchor.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc instrument::Flush {} {
+ # Emit any pending text and advance the anchor
+
+ set end [expr {[lindex $::instrument::anchorEnd 0] \
+ + [lindex $::instrument::anchorEnd 1]}]
+ append ::instrument::result [parse getstring $::instrument::script \
+ [list $::instrument::anchorStart \
+ [expr {$end - $::instrument::anchorStart}]]]
+ set ::instrument::anchorStart $end
+ set ::instrument::anchorEnd [list $end 0]
+ return
+}
+
+# instrument::appendString --
+#
+# Emit everything between the anchor and the cursor and append
+# the specified string.
+#
+# Arguments:
+# string The string to append.
+#
+# Results:
+# None.
+
+proc instrument::appendString {string} {
+ Flush
+ append ::instrument::result $string
+ return
+}
+
+# instrument::beginCommand --
+#
+# Begin instrumentation of a new command. This routine takes
+# care of various bookkeeping functions like updating the anchor
+# and the location. It also pushes a new result accumulator.
+#
+# Arguments:
+# cmdRange The range of the current command.
+#
+# Results:
+# None.
+
+proc instrument::beginCommand {cmdRange} {
+ variable cmdInfoStack
+ variable result
+ variable suppress
+
+ # Update the line number and set the anchor at the beginning of the
+ # command, skipping over any comments or whitespace.
+
+ setLocation $cmdRange
+ setAnchor $cmdRange
+
+ # Save the information about the current command and then set up
+ # for the nested command.
+ lappend cmdInfoStack [list [getLocation] $suppress $result]
+ set result {}
+ set suppress 0
+
+ return
+}
+
+# instrument::endCommand --
+#
+# Emit the transformed command string and restore the command info.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc instrument::endCommand {cmdRange} {
+ variable cmdInfoStack
+ variable result
+ variable suppress
+ variable isSubcommand
+ variable lines
+ variable ranges
+
+ correctForExpandOp
+
+ # Ensure that everything up to the end of the range has been emitted.
+ setCursor $cmdRange
+ Flush
+
+ # Save values that were computed for this command
+ set cmdString $result
+ set cmdSuppress $suppress
+
+ # Restore the command info
+ lassign [lindex $cmdInfoStack end] cmdLocation suppress result isSubCommand
+ set cmdInfoStack [lreplace $cmdInfoStack end end]
+
+ if {!$cmdSuppress} {
+ lappend lines [loc::getLine $cmdLocation]
+ lappend ranges [loc::getRange $cmdLocation]
+ appendString [list DbgNub_Do $isSubcommand $cmdLocation $cmdString]
+ } else {
+ appendString $cmdString
+ }
+ return
+}
+
+proc instrument::correctForExpandOp {} {
+ set locEnd [
+ parse getstring $::instrument::script [
+ lindex $::instrument::location 2
+ ]
+ ]
+
+ if {[string first {{*}} $locEnd] < 0} {return}
+ upvar cmdRange cmdRange
+
+ set locEnd [string trimright $locEnd]
+
+ set locStart [lindex $::instrument::location 2 0]
+ set cmdEnd [
+ string trimright [
+ parse getstring $::instrument::script "
+ $locStart [expr [string map {{ } +} $cmdRange]-$locStart]
+ "
+ ]
+ ]
+
+ if {$locEnd eq $cmdEnd} {return}
+
+ lassign $cmdRange r1 r2
+ incr r2 [expr [string length $locEnd] - [string length $cmdEnd]]
+ set cmdRange "$r1 $r2"
+}
+
+# instrument::isLiteral --
+#
+# Check to see if a word only contains text that doesn't need to
+# be substituted.
+#
+# Arguments:
+# word The token for the word to check.
+#
+# Results:
+# Returns 1 if the word contains no variable or command substitutions,
+# otherwise returns 0.
+
+proc instrument::isLiteral {word} {
+ variable script
+
+ if {[lindex $word 0] != "simple"} {
+ foreach token [lindex $word 2] {
+ set type [lindex $token 0]
+ if {$type != "text" && $type != "backslash"} {
+ return 0
+ }
+ }
+
+ # The text contains backslash sequences. Bail if the text is
+ # not in braces because this would require complicated substitutions.
+ # Braces are a special case because only \newline is interesting and
+ # this won't interfere with recursive parsing.
+
+ if {[string index $script [parse charindex $script [lindex $word 1]]] \
+ == "\{"} {
+ return 1
+ } else {
+ return 0
+ }
+ }
+ return 1
+}
+
+# instrument::getLiteral --
+#
+# Retrieve the literal string value of a word.
+#
+# Arguments:
+# word The token for the word to fetch.
+# resultVar The name of a variable where the text should be
+# stored.
+#
+# Results:
+# Returns 1 if the text contained no variable or command substitutions,
+# otherwise returns 0.
+
+proc instrument::getLiteral {word resultVar} {
+ variable script
+
+ upvar $resultVar result
+ set result ""
+ foreach token [lindex $word 2] {
+ set type [lindex $token 0]
+ if {$type == "text"} {
+ append result [parse getstring $script [lindex $token 1]]
+ } elseif {$type == "backslash"} {
+ append result [subst [parse getstring $script [lindex $token 1]]]
+ } else {
+ set result [parse getstring $script [lindex $word 1]]
+ return 0
+ }
+ }
+ return 1
+}
+
+# instrument::Instrument --
+#
+# Instrument a block of code.
+#
+# Arguments:
+# block The block to instrument.
+#
+# Results:
+# Returns the instrumented string, or "" if the
+# script failed to be instrumented.
+
+proc instrument::Instrument {block} {
+ # Instrumenting a new script.
+ if {$::instrument::busy} {
+ error "The instrumenter is being called while in use!"
+ }
+ set ::instrument::busy 1
+
+ Init $block
+ if {[catch {parseScript} msg]} {
+ global errorCode
+
+ # If the error is generated by the instrumenter because the
+ # script failed to parse, we should restore the original errorCode
+ # before returning, otherwise we need to report the error.
+
+ if {[lindex $errorCode 0] != "CAUGHT"} {
+ bgerror $msg
+ } else {
+ set errorCode [lindex $errorCode 1]
+ }
+
+ # Instrumentation failed, so return an empty script.
+
+ set ::instrument::busy 0
+ return {}
+ } else {
+ Flush
+ set ::instrument::busy 0
+ return $::instrument::result
+ }
+
+}
+
+# instrument::parseScript --
+#
+# Instrument a script. This procedure may be called directly
+# to instrument a new script, or recursively to instrument
+# subcommands and control function arguments. If called with
+# only a block arg, it is assumed to be a new script and line
+# number information is initialized.
+#
+# Arguments:
+# scriptRange The range in the script to instrument. A
+# default of {} indicates the whole script.
+#
+# Results:
+# None.
+
+proc instrument::parseScript {{scriptRange {}}} {
+ # Iterate over all of the commands in the script range, advancing the
+ # range at the end of each command.
+
+ variable script
+
+ pushContext
+ set first 1
+ if {$scriptRange == ""} {
+ set scriptRange [parse getrange $script]
+ }
+ for {} {[parse charlength $script $scriptRange] > 0} \
+ {set scriptRange $tail} {
+ # Parse the next command
+
+ if {[catch {lassign [parse command $script $scriptRange] \
+ comment cmdRange tail tree}]} {
+ # An error occurred during parsing.
+
+ if {$instrument::errorHandler != ""} {
+ pushContext
+ setLocation [list [lindex $::errorCode 2] 1]
+ set location [getLocation]
+ popContext
+ if {[$instrument::errorHandler $location]} {
+ # Ignore the error and wrap the rest of the script
+ # as a single statement.
+
+ if {!$first} {
+ appendString \n
+ }
+ beginCommand $scriptRange
+ # Do nothing so the text is emitted verbatim
+ endCommand $scriptRange
+ break
+ }
+ }
+ # Note we are bailing all the way out here, so we don't need
+ # to pop the context or do any other cleanup.
+
+ error "Unable to parse" $::errorInfo [list CAUGHT $::errorCode]
+ }
+
+ if {([llength $tree] == 0) \
+ || ([parse charlength $script $cmdRange] <= 0)} {
+ continue
+ }
+
+ if {!$first} {
+ appendString \n
+ } else {
+ set first 0
+ }
+
+ set index 0
+ beginCommand $cmdRange
+ set argc [llength $tree]
+ while {$index < $argc} {
+ set cmdToken [lindex $tree $index]
+ if {[getLiteral $cmdToken cmdName]} {
+ incr index
+ set cmdName [string trimleft $cmdName :]
+ if {[info exists instrument::handler($cmdName)]} {
+ set index [eval $instrument::handler($cmdName) \
+ {$tree $index}]
+ } else {
+ set index [parseCommand $tree $index]
+ }
+ } else {
+ set index [parseCommand $tree $index]
+ }
+ }
+ endCommand [lindex [lindex $tree end] 1]
+ }
+ popContext
+ return
+}
+
+# instrument::parseCommand --
+#
+# This is the generic command wrapper.
+#
+# Arguments:
+# tokens The list of word tokens for the current command.
+# index The index of the next word to be parsed.
+#
+# Results:
+# Returns the index of the next token to be parsed.
+
+proc instrument::parseCommand {tokens index} {
+ set argc [llength $tokens]
+ while {$index < $argc} {
+ set index [parseWord $tokens $index]
+ }
+ setCursor [lindex [lindex $tokens end] 1]
+ return $argc
+}
+
+# instrument::parseWord --
+#
+# Examine a token for subcommands.
+#
+# Arguments:
+# tokens The list of word tokens for the current command.
+# index The index of the next word to be parsed.
+#
+# Results:
+# Returns the index of the next token to be parsed.
+# Emits the instrumented text of the token, leaving the
+# cursor pointing just after the token.
+
+proc instrument::parseWord {tokens index} {
+ set word [lindex $tokens $index]
+ set type [lindex $word 0]
+ switch -- $type {
+ subexpr -
+ variable -
+ word {
+ foreach subword [lindex $word 2] {
+ parseWord [list $subword] 0
+ }
+ }
+ command {
+ variable isSubcommand
+ set oldState $isSubcommand
+ set isSubcommand 1
+
+ set range [lindex $word 1]
+ set range [list [expr {[lindex $range 0] + 1}] \
+ [expr {[lindex $range 1] - 2}]]
+ setCursor [list [lindex $range 0] 0]
+ parseScript $range
+
+ set isSubcommand $oldState
+ }
+ }
+ setCursor [lindex $word 1]
+ return [incr index]
+}
+
+# instrument::parseBody --
+#
+# Attempt to parse a word like it is the body of a control
+# structure. If the word is a simple string, it emits tags to
+# indicate that the body is instrumented and passes it to
+# parseScript, otherwise it just treats it like a normal word
+# and looks for subcommands.
+#
+# Arguments:
+# bodyProc Optional. The procedure to invoke to handle
+# parsing the body script.
+# tokens The list of word tokens for the current command.
+# index The index of the next word to be parsed.
+#
+# Results:
+# Returns the index of the next token to be parsed..
+
+proc instrument::parseBody {args} {
+ variable isSubcommand
+ variable script
+
+ if {[llength $args] == 2} {
+ lassign $args tokens index
+ set bodyProc parseScript
+ } else {
+ lassign $args bodyProc tokens index
+ }
+
+ set word [lindex $tokens $index]
+
+ set oldState $isSubcommand
+ set isSubcommand 0
+
+ if {[isLiteral $word]} {
+ set quote [string index $script \
+ [parse charindex $script [lindex $word 1]]]
+ set range [lindex $word 1]
+ set addBrace 0
+ if {$quote == "\""} {
+ set range [list [expr {[lindex $range 0] + 1}] \
+ [expr {[lindex $range 1] - 2}]]
+ set closeChar "\""
+ } elseif {$quote == "\{"} {
+ set range [list [expr {[lindex $range 0] + 1}] \
+ [expr {[lindex $range 1] - 2}]]
+ set closeChar "\}"
+ } else {
+ set closeChar "\}"
+ set addBrace 1
+ }
+
+ setCursor [list [lindex $range 0] 0]
+ if {$addBrace} {
+ appendString \{
+ }
+
+ # At this point the location should point to the command being
+ # instrumented (e.g. the whole "proc" statement).
+
+ appendString "\n# DBGNUB START: [list [getLocation]]\n"
+ $bodyProc $range
+ appendString "\n# DBGNUB END\n$closeChar"
+ setAnchor [list [expr {[lindex [lindex $word 1] 0] \
+ + [lindex [lindex $word 1] 1]}] 0]
+ incr index
+ } else {
+ set index [parseWord $tokens $index]
+ }
+ set isSubcommand $oldState
+ return $index
+}
+
+# instrument::parseOption --
+#
+# This function handles parsing of subcommand options.
+#
+# Arguments:
+# optionTable A list of pairs describing the valid options. Each
+# pair is an option name followed by a command prefix.
+# default The action to take if no matching options are present.
+# tokens The list of tokens for the current command.
+# index The index of the next word to be parsed.
+#
+# Results:
+# Returns the next token to be parsed.
+
+proc instrument::parseOption {optionTable default tokens index} {
+ if {($index == [llength $tokens]) && ($default == "")} {
+ return $index
+ }
+
+ set word [lindex $tokens $index]
+ if {![getLiteral $word value]} {
+ return [parseCommand $tokens $index]
+ }
+
+ set keywords {}
+ foreach keyword $optionTable {
+ lappend keywords [lindex $keyword 0]
+ }
+
+ if {![matchKeyword $optionTable $value 0 script]} {
+ if {$default != ""} {
+ set script $default
+ } else {
+ set script parseCommand
+ }
+ } else {
+ incr index
+ }
+ return [eval $script {$tokens $index}]
+
+}
+
+# instrument::parseSimpleArgs --
+#
+# This function applies a sequence of actions to each argument
+# in the command until there are no more arguments. If there are
+# more arguments than actions, then the last action is repeated
+# for each trailing argument. If the number of arguments falls
+# outside of the min/max bounds, then the command is just passed
+# to parseCommand.
+#
+# Arguments:
+# min The minimum number of arguments allowed.
+# max The maximum number of arguments allowed.
+# argList A list of scripts that should be called for
+# the corresponding argument.
+# tokens The list of word tokens for the current command.
+# index The index of the next word to be parsed.
+#
+# Results:
+# Returns the index of the next token to be parsed.
+
+proc instrument::parseSimpleArgs {min max argList tokens index} {
+ set argc [llength $tokens]
+
+ if {$argc < ($min + $index) \
+ || (($max > -1) && ($argc > ($max + $index)))} {
+ return [parseCommand $tokens $index]
+ }
+
+ while {$index < $argc} {
+ set index [eval [lindex $argList 0] {$tokens $index}]
+ if {[llength $argList] > 1} {
+ set argList [lrange $argList 1 end]
+ }
+ }
+ return $argc
+}
+
+proc instrument::parseTryCmd {tokens index} {
+ set i $index
+ set argc [llength $tokens]
+ set commands ""
+ set failed 0
+ set text {}
+
+ if {[catch {
+ while {1} {
+
+ append commands "parseBody \$tokens $i\n"
+ incr i
+ if {$i >= $argc} {
+ # We completed successfully so bail out to the catch
+ return
+ }
+
+ if {[getLiteral [lindex $tokens $i] text] && ($text in {on trap})} {
+ incr i 3
+ continue
+ } elseif {$text eq {finally}} {
+ incr i
+ continue
+ } else {
+ error {}
+ }
+ break
+ }
+
+ }] == 1} {
+ parseCommand $tokens $index
+ } else {
+ eval $commands
+ }
+ return $argc
+}
+
+proc instrument::parseApplyCmd {tokens index} {
+ set word [lindex $tokens $index]
+ if {![isLiteral $word]} {
+ return [parseCommand $tokens $index]
+ }
+
+ return [wrapCommand DbgNub_Apply {1 100000} {parseWord} $tokens $index]
+}
+
+# instrument::parseTail --
+#
+# This function is similar to parseSimpleArgs, except it matches
+# arguments with scripts starting from the end. If there are more
+# arguments than scripts, the first one listed is used for all of
+# the leading arguments. If there are fewer arguments than scripts
+# scripts will be dropped from the beginning of the list until the
+# correct number is reached.
+#
+# Arguments:
+# min The minimum number of arguments required to use the
+# argCmds instead of parseCommand.
+# argCmds A list of scripts that should be called for
+# the corresponding argument.
+# tokens The list of word tokens for the current command.
+# index The index of the next word to be parsed.
+#
+# Results:
+# Returns the index of the next token to be parsed.
+
+proc instrument::parseTail {min argCmds tokens index} {
+ set argc [llength $tokens]
+ set cmdc [llength $argCmds]
+ set count [expr {$argc - $index}]
+
+ if {$count < $min} {
+ return [parseCommand $tokens $index]
+ }
+ if {$count < $cmdc} {
+ set argCmds [lrange $argCmds [expr {$cmdc - $count}] end]
+ }
+ while {$index < $argc} {
+ set index [eval [lindex $argCmds 0] {$tokens $index}]
+ if {($argc - $index) < $cmdc} {
+ set argCmds [lrange $argCmds 1 end]
+ }
+ }
+ return $argc
+}
+
+
+# instrument::parseSwitches --
+#
+# This function parses optional switch arguments.
+#
+# Arguments:
+# exact Boolean value. If true, then switches have to match
+# exactly.
+# switches A list of switch/action pairs. The action may be
+# omitted if the switch does not take an argument.
+# If "--" is included, it acts as a terminator.
+# chainCmd The command to use to check the remainder of the
+# command line arguments. May be null for trailing
+# switches.
+# tokens The list of word tokens for the current command.
+# index The index of the next word to be checked.
+#
+# Results:
+# Returns the index of the next token to be parsed.
+
+proc instrument::parseSwitches {exact switches chainCmd tokens index} {
+ set argc [llength $tokens]
+ while {$index < $argc} {
+ set word [lindex $tokens $index]
+ if {![getLiteral $word value]} {
+ break
+ }
+ if {[string index $value 0] != "-"} {
+ break
+ }
+
+ set script ""
+ if {![matchKeyword $switches $value $exact script]} {
+ return [parseCommand $tokens $index]
+ } else {
+ incr index
+ if {$value == "--"} {
+ break
+ }
+ if {$script != ""} {
+ if {$index >= $argc} {
+ return $argc
+ }
+
+ set index [eval $script {$tokens $index}]
+ }
+ }
+ }
+ if {$chainCmd != ""} {
+ return [eval $chainCmd {$tokens $index}]
+ }
+ return $index
+}
+
+# instrument::wrapCommand --
+#
+# This function backs up to the command token and inserts a command
+# string.
+#
+# Arguments:
+# newName The new command string.
+# numArgs Only wrap the command if the number of arguments
+# matches the specified number (or range of numbers).
+# argList A list of scripts that should be called for
+# the corresponding argument.
+# tokens The list of word tokens for the current command.
+# index The index of the next word to be parsed.
+#
+# Results:
+# Returns the index of the next token to be parsed.
+
+proc instrument::wrapCommand {newName numArgs argList tokens index} {
+ variable result
+
+ set argc [llength $tokens]
+
+ if {[llength $numArgs] == 1} {
+ set min $numArgs
+ set max $numArgs
+ } else {
+ set min [lindex $numArgs 0]
+ set max [lindex $numArgs 1]
+ }
+ set rest [expr {[llength $tokens] - $index}]
+ if {$rest < $min || $rest > $max} {
+ return [parseCommand $tokens $index]
+ }
+ set result "$newName $result"
+ while {$index < $argc} {
+ set index [eval [lindex $argList 0] {$tokens $index}]
+ if {[llength $argList] > 1} {
+ set argList [lrange $argList 1 end]
+ }
+ }
+ return $argc
+}
+
+# instrument::parseExpr --
+#
+# Attempt to parse a word like it is an expression.
+# If the word is a simple string, it is examined for subcommands
+# within the expression, otherwise it is handled like a normal word.
+#
+# Arguments:
+# tokens The list of word tokens for the current command.
+# index The index of the next word to be parsed.
+#
+# Results:
+# None.
+
+proc instrument::parseExpr {tokens index} {
+ set word [lindex $tokens $index]
+
+ # Don't attempt to parse as an expression if the text contains
+ # substitutions.
+
+ if {![isLiteral $word]} {
+ return [parseWord $tokens $index]
+ }
+
+ # Compute the range of the expression from the first and last token in
+ # the word.
+
+ set start [lindex [lindex [lindex [lindex $word 2] 0] 1] 0]
+ set end [lindex [lindex [lindex $word 2] end] 1]
+ set range [list $start [expr {[lindex $end 0] + [lindex $end 1] - $start}]]
+
+
+ # Parse the word as an expression looking for subcommands.
+
+ setCursor [list $start 0]
+ if {[catch {parse expr $::instrument::script $range} tree]} {
+ # An error occurred during parsing.
+
+ if {$instrument::errorHandler != ""} {
+ pushContext
+ setLocation [list [lindex $::errorCode 2] 1]
+ set location [getLocation]
+ popContext
+ if {[$instrument::errorHandler $location]} {
+ # Ignore the error and just parse the expression as
+ # a normal word.
+ return [parseWord $tokens $index]
+ }
+ }
+ error "Unable to parse" $::errorInfo [list CAUGHT $::errorCode]
+ }
+ parseWord [list $tree] 0
+ setCursor [lindex $word 1]
+ return [incr index]
+
+}
+
+#
+# Incr Tcl specific procedures
+#
+
+
+# instrument::parseIncr22Class --
+#
+# This is a very special script parser for the incr Tcl
+# class command (version 2.2 only). This will only
+# instrument the bodies of special functions and will
+# not instrument anything at the toplevel.
+#
+# Arguments:
+# range The range of the body being parsed.
+#
+# Results:
+# Returns the instrumented code.
+
+proc instrument::parseIncr22Class {range} {
+ # Iterate over all of the commands in the script range, advancing the
+ # range at the end of each command.
+
+ variable script
+
+ pushContext
+ set first 1
+ for {} {[parse charlength $script $range] > 0} \
+ {set range $tail} {
+ # Parse the next command
+
+ if {[catch {lassign [parse command $script $range] \
+ comment cmdRange tail tree}]} {
+ # An error occurred during parsing.
+
+ if {$instrument::errorHandler != ""} {
+ pushContext
+ setLocation [list [lindex $::errorCode 2] 1]
+ set location [getLocation]
+ popContext
+ if {[$instrument::errorHandler $location]} {
+ # Ignore the error and skip to the end of the statement.
+
+ if {!$first} {
+ appendString \n
+ }
+
+ # Emit everything else as a single command with no
+ # instrumentation.
+
+ beginCommand $range
+ set ::instrument::suppress 1
+ endCommand $range
+ break
+ }
+ }
+ # Note we are bailing all the way out here, so we don't need
+ # to pop the context or do any other cleanup.
+
+ error "Unable to parse" $::errorInfo [list CAUGHT $::errorCode]
+ }
+
+ if {([llength $tree] == 0) \
+ || ([parse charlength $script $cmdRange] <= 0)} {
+ continue
+ }
+
+ if {!$first} {
+ appendString "\n"
+ } else {
+ set first 0
+ }
+
+ # Update the line number and set the anchor at the beginning of the
+ # command, skipping over any comments or whitespace.
+
+ beginCommand $cmdRange
+
+ set ::instrument::suppress 1
+
+ set argc [llength $tree]
+ set index 0
+ while {$index < $argc} {
+ set cmdToken [lindex $tree $index]
+ if {[getLiteral $cmdToken cmdName]} {
+ incr index
+ set cmdName [string trimleft $cmdName :]
+ switch -- $cmdName {
+ private -
+ protected -
+ public {
+ # Skip over the protection keyword and continue
+ # with the next word unless there is only one more
+ # token in which case a body will follow
+ if {($argc - $index) != 1} {
+ continue
+ }
+ set index [parseBody parseIncr22Class $tree $index]
+ }
+ variable {
+ if {($argc - $index) != 3} {
+ break
+ }
+ set index [parseItclBody parseConfigure $tree \
+ [expr {$argc - 1}]]
+ }
+ proc -
+ method {
+ if {($argc - $index) != 3} {
+ break
+ }
+ set index [parseItclBody parseMethod $tree \
+ [expr {$argc - 1}]]
+ }
+ constructor {
+ set len [expr {($argc - $index)}]
+ if {($len != 2) && ($len != 3)} {
+ break
+ }
+ set index [parseItclBody parseMethod $tree \
+ [expr {$argc - 1}]]
+ }
+ destructor {
+ if {($argc - $index) != 1} {
+ break
+ }
+ set index [parseItclBody parseMethod $tree $index]
+ }
+ default {
+ # Skip to the end of the command since we can't
+ # instrument anything at the top level of the class
+ # declaration.
+ break
+ }
+ }
+ } else {
+ set index [parseCommand $tree $index]
+ }
+ }
+ endCommand [lindex [lindex $tree end] 1]
+ }
+ popContext
+ return
+}
+
+# instrument::parseIncr22NSBody --
+#
+# This function parses the last argument to "namespace" for
+# [incr Tcl] 2.2 to handle the special case where it begins with a
+# dash and so isn't a valid body.
+#
+# Arguments:
+# tokens The list of word tokens for the current command.
+# index The index of the next word to be parsed.
+#
+# Results:
+# Returns the index of the next token to be parsed.
+
+proc instrument::parseIncr22NSBody {tokens index} {
+ set word [lindex $tokens $index]
+ if {[getLiteral $word string] && ([string index $string 0] == "-")} {
+ return [parseWord $tokens $index]
+ } else {
+ return [wrapCommand DbgNub_NamespaceEval 1 {parseBody} $tokens $index]
+ }
+}
+
+# instrument::parseItclBody --
+#
+# This is a generic wrapper function that handles the special
+# syntax of an [incr Tcl] body.
+#
+# Arguments:
+# script The script to invoke on the body.
+# tokens The list of word tokens for the current command.
+# index The index of the next word to be parsed.
+#
+# Results:
+# Returns the index of the next token to be parsed.
+
+proc instrument::parseItclBody {args} {
+ if {[llength $args] == 3} {
+ lassign $args script tokens index
+ } else {
+ lassign $args tokens index
+ set script ""
+ }
+ set word [lindex $tokens $index]
+ if {[getLiteral $word string] && ([string index $string 0] == "@")} {
+ parseWord $tokens $index
+ } else {
+ if {$script != ""} {
+ parseBody $script $tokens $index
+ } else {
+ parseBody $tokens $index
+ }
+ }
+ return [incr index]
+}
+
+# instrument::parseMethod --
+#
+# Parse an [incr Tcl] 2.2 method body and emit code to transfer the value
+# cached by DbgNub_Return into a proper result. This is equivalent to
+# DbgNub_WrapItclBody, but since we can't uplevel into a class context
+# in version 2.2, we have to emit the code inline. Be sure to keep
+# these two functions in sync.
+#
+# Arguments:
+# range The range of the body being parsed.
+#
+# Results:
+# None.
+
+proc instrument::parseMethod {range} {
+ appendString "#DBG INSTRUMENTED PROC TAG
+ upvar #0 errorInfo DbgNub_errorInfo errorCode DbgNub_errorCode
+ set DbgNub_level \[DbgNub_infoCmd level\]
+ eval \[list DbgNub_PushContext \$DbgNub_level\] \[info function \[lindex \[info level 0\] 0\] -type -name -args\]
+ set DbgNub_catchCode \[DbgNub_UpdateReturnInfo \[DbgNub_catchCmd {\n"
+ parseScript $range
+ appendString "\n} DbgNub_result\]\]
+ foreach DbgNub_index \[info locals\] {
+ if {\[trace vinfo \$DbgNub_index\] != \"\"} {
+ if {[catch {upvar 0 DbgNub_dummy \$DbgNub_index}]} {
+ catch {unset \$DbgNub_index}
+ }
+ }
+ catch {unset \$DbgNub_index}
+ }
+ DbgNub_PopContext
+ return -code \$DbgNub_catchCode -errorinfo \$DbgNub_errorInfo -errorcode \$DbgNub_errorCode \$DbgNub_result"
+ return
+}
+
+# instrument::parseConfigure --
+#
+# Parse an [incr Tcl] 2.2 configure body. This is equivalent to
+# DbgNub_WrapItclConfig, but since we can't uplevel into a class context
+# in version 2.2, we have to emit the code inline. Be sure to keep
+# these two functions in sync.
+#
+# Arguments:
+# range The range of the body being parsed.
+#
+# Results:
+# None.
+
+proc instrument::parseConfigure {range} {
+ appendString "DbgNub_ItclConfig {\n"
+ parseScript $range
+ appendString "\n}"
+ return
+}
+
+# instrument::simpleControl --
+#
+# This is a generic wrapper function that handles simple control
+# constructs where one or more arguments are scripts.
+#
+# Arguments:
+# bodies A list of integers specifying the argument positions
+# that contain scripts.
+# tokens The parse tokens for the command.
+# index The index of the next word to be parsed.
+#
+# Results:
+# Returns the index of the next token to be parsed.
+
+proc instrument::simpleControl {bodies tokens index} {
+ set argc [llength $tokens]
+ set offset $index
+
+ while {$index < $argc} {
+ if {[lsearch -exact $bodies [expr {$index - $offset}]] >= 0} {
+ parseBody $tokens $index
+ } else {
+ parseWord $tokens $index
+ }
+ incr index
+ }
+ return $index
+}
+
+# instrument::itclProtection --
+#
+# This is the generic handler for any of the Itcl protection
+# commands (public, private, protected).
+#
+# Arguments:
+# tokens The parse tokens for the command.
+# index The index of the next word to be parsed.
+#
+# Results:
+# Returns the index of the next token to be parsed.
+
+proc instrument::itclProtection {tokens index} {
+ variable suppress
+ set argc [llength $tokens]
+
+ if {$argc == $index} {
+ return [parseCommand $tokens $index]
+ } elseif {($argc - $index) == 1} {
+ set word [lindex $tokens $index]
+ set suppress 1
+ return [parseBody $tokens $index]
+ } else {
+ # Restart command lookup on the current token
+ return $index
+ }
+}
+
+# instrument::pushHandlers --
+#
+# Pushes a set of handlers, returning the old set in a list.
+#
+# Arguments:
+# newList A list of handler/action pairs to be set into the
+# handlers array.
+#
+# Results:
+# Returns a list of handler/action pairs corresponding to the old
+# values.
+
+proc instrument::pushHandlers {newList} {
+ variable handler
+
+ set oldWrappers {}
+ foreach pair $newList {
+ set cmd [lindex $pair 0]
+ lappend oldWrappers [list $cmd $handler($cmd)]
+ set handler($cmd) [lindex $pair 1]
+ }
+ return $oldWrappers
+}
+
+# instrument::popHandlers --
+#
+# Restore a set of handlers saved by a previous call to pushHandlers.
+#
+# Arguments:
+# saveList The list of handler/action pairs to restore.
+#
+# Results:
+# None.
+
+proc instrument::popHandlers {saveList} {
+ variable handler
+
+ foreach pair $saveList {
+ set handler([lindex $pair 0]) [lindex $pair 1]
+ }
+ return
+}
+
+# instrument::leaveClass --
+#
+# Push a non-class context.
+#
+# Arguments:
+# args The remainder of the command to invoke.
+#
+# Results:
+# Returns the index of the next token to be parsed.
+
+proc instrument::leaveClass {args} {
+ set save [pushHandlers {
+ {constructor parseCommand}
+ {destructor parseCommand}
+ {method parseCommand}
+ {proc {parseSimpleArgs 3 3 {parseWord parseWord parseBody}}}
+ {variable parseCommand}
+ {private parseCommand}
+ {protected parseCommand}
+ {public parseCommand}
+ }]
+
+ set index [eval $args]
+ popHandlers $save
+ return $index
+}
+
+# instrument::parseItclClass --
+#
+# This routine wraps a Itcl 3.0 or later class.
+#
+# Arguments:
+# tokens The parse tokens for the command.
+# index The index of the next word to be parsed.
+#
+# Results:
+# Returns the index of the next token to be parsed.
+
+proc instrument::parseItclClass {tokens index} {
+ variable handler
+
+ # Set up the class context
+
+ set save [pushHandlers {
+ {constructor {leaveClass wrapCommand DbgNub_Constructor {2 3} \
+ {parseWord parseItclBody}}}
+ {destructor {leaveClass wrapCommand DbgNub_WrapItclBody 1 \
+ {parseItclBody}}}
+ {method {leaveClass wrapCommand DbgNub_WrapItclBody 3 \
+ {parseWord parseWord parseItclBody}}}
+ {proc {leaveClass wrapCommand DbgNub_WrapItclBody 3 \
+ {parseWord parseWord parseItclBody}}}
+ {variable {leaveClass wrapCommand DbgNub_WrapItclConfig 3 \
+ {parseWord parseWord parseItclBody}}}
+ {private itclProtection}
+ {protected itclProtection}
+ {public itclProtection}
+ }]
+
+ # Now parse the body of the class
+
+ if {[llength $tokens] == 3} {
+ set index [wrapCommand DbgNub_Class 2 {parseWord parseBody} \
+ $tokens $index]
+ } else {
+ set index [parseCommand $tokens $index]
+ }
+
+ # Restore the previous command wrappers
+
+ popHandlers $save
+ return $index
+}
+
+# instrument::parseReturnCmd --
+#
+# This routine wraps the return command.
+#
+# Arguments:
+# tokens The parse tokens for the command.
+# index The index of the next word to be parsed.
+#
+# Results:
+# Returns the index of the next token to be parsed.
+
+proc instrument::parseReturnCmd {tokens index} {
+ set argc [llength $tokens]
+
+ # We only need to wrap the return command if it uses the -code
+ # option. If we have 2 or fewer arguments then they couldn't
+ # be using the -code option and we don't need to treat this
+ # command specially.
+
+ if {($argc - $index) < 2} {
+ return [parseCommand $tokens $index]
+ }
+
+ # We replace the call to "return" with a call to "DbgNub_Return"
+ # so we can handle the weird case of -code being used.
+
+ appendString "DbgNub_Return "
+ setAnchor [lindex [lindex $tokens 1] 1]
+ while {$index < $argc} {
+ set index [parseWord $tokens $index]
+ }
+ return $index
+}
+
+# instrument::parseIfCmd --
+#
+# This routine wraps the if command.
+#
+# Arguments:
+# tokens The parse tokens for the command.
+# index The index of the next word to be parsed.
+#
+# Results:
+# Returns the index of the next token to be parsed.
+
+proc instrument::parseIfCmd {tokens index} {
+ set i $index
+ set argc [llength $tokens]
+ set commands ""
+ set failed 0
+ set text {}
+
+ # Look ahead to determine if this is a well formed if statement
+ # The control flow is a little complicated here so we use a catch to
+ # implement a nonlocal jump to the end. If the body of the catch
+ # calls "error", the command didn't parse correctly, so we just call the
+ # generic parseCommand routine. Otherwise if the body of the catch calls
+ # "return" or completes normally, we execute the accumulated commands to
+ # emit the instrumented statement.
+
+ if {[catch {
+ while {1} {
+ # At this point in the loop, lindex i refers to an expression
+ # to test, either for the main expression or an expression
+ # following an "elseif". The arguments after the expression must
+ # be "then" (optional) and a script to execute.
+
+ append commands "parseExpr \$tokens $i\n"
+ if {$i >= $argc} {
+ error {}
+ }
+ incr i
+ if {($i < $argc) \
+ && [getLiteral [lindex $tokens $i] text] \
+ && ($text == "then")} {
+ incr i
+ }
+
+ if {$i >= $argc} {
+ error {}
+ }
+ append commands "parseBody \$tokens $i\n"
+ incr i
+ if {$i >= $argc} {
+ # We completed successfully so bail out to the catch
+ return
+ }
+
+ if {[getLiteral [lindex $tokens $i] text] && ($text == "elseif")} {
+ incr i
+ continue
+ }
+ break
+ }
+
+ # Now we check for an else clause
+ if {[getLiteral [lindex $tokens $i] text] && ($text == "else")} {
+ incr i
+
+ if {$i >= $argc} {
+ error {}
+ }
+ }
+ if {($i+1) != $argc} {
+ error {}
+ }
+ append commands "parseBody \$tokens $i\n"
+ }] == 1} {
+ parseCommand $tokens $index
+ } else {
+ eval $commands
+ }
+ return $argc
+}
+
+
+# instrument::parseSwitchCmd --
+#
+# This routine wraps the switch command.
+#
+# Arguments:
+# tokens The parse tokens for the command.
+# index The index of the next word to be parsed.
+#
+# Results:
+# Returns the index of the next token to be parsed.
+
+proc instrument::parseSwitchCmd {tokens index} {
+ set argc [llength $tokens]
+ set i $index
+
+ if {$argc < 3} {
+ return [parseCommand $tokens $index]
+ }
+
+ set argc [llength $tokens]
+ set i 1
+
+ set commands ""
+ set failed 0
+
+ # Look ahead to determine if this is an instrumentable switch statement.
+ # The control flow is a little complicated here so we use a catch to
+ # implement a nonlocal jump to the end. If the body of the catch
+ # calls "error", the command didn't parse correctly, so we just call the
+ # generic parseCommand routine. Otherwise if the body of the catch calls
+ # "return" or completes normally, we execute the accumulated commands to
+ # emit the instrumented statement.
+
+ if {[catch {
+ # Skip past the switch arguments
+ while {$i < $argc} {
+ if {![getLiteral [lindex $tokens $i] string]} {
+ break
+ }
+ switch -exact -- $string {
+ -exact -
+ -glob -
+ -regexp -
+ -nocase {
+ incr i
+ }
+ -matchvar -
+ -indexvar {
+ incr i 2
+ }
+ -- {
+ incr i
+ break
+ }
+ default {
+ break
+ }
+ }
+ }
+
+ append commands "setCursor [list [lindex [lindex $tokens [expr {$i - 1}]] 1]]\n"
+
+ # The next argument should be the string to switch on.
+
+ append commands "parseWord \$tokens $i\n"
+ incr i
+
+ # We are then left with two cases: 1. one argument which
+ # need to split into words. Or 2. a bunch of pattern body
+ # pairs.
+
+ if {($i + 1) == $argc} {
+ # Check to be sure the body doesn't contain substitutions
+
+ set bodyToken [lindex $tokens $i]
+ if {![isLiteral $bodyToken]} {
+ append commands "parseWord \$tokens $i\n"
+ incr i
+ # We can't descend here so we jump to the end
+ return
+ }
+
+ # If the body token contains backslash sequences, there will
+ # be more than one subtoken, so we take the range for the whole
+ # body and subtract the braces. Otherwise it's a "simple" word
+ # with only one part and we can get the range from the text
+ # subtoken.
+
+ if {[llength [lindex $bodyToken 2]] > 1} {
+ set range [lindex $bodyToken 1]
+ set range [list [expr {[lindex $range 0] + 1}] \
+ [expr {[lindex $range 1] - 2}]]
+ } else {
+ set range [lindex [lindex [lindex $bodyToken 2] 0] 1]
+ }
+
+ append commands "setCursor [list [list [lindex $range 0] 0]]\n"
+
+ foreach {pattern body} [parse list $::instrument::script $range] {
+ append commands "setCursor [list $pattern]\n"
+
+ # If the body is not "-", parse it as a command word and pass
+ # the result to parseBody. This isn't quite right, but it
+ # should handle the common cases.
+
+ if {$body != "" && [parse getstring $::instrument::script $body] != "-"} {
+ append commands "parseBody \[lindex \
+ \[parse command \$::instrument::script [list $body]\] \
+ 3\] 0\n"
+ }
+ }
+ append commands "setCursor [list [lindex $bodyToken 1]]\n"
+ } else {
+ while {$i < $argc} {
+ append commands "parseWord \$tokens $i\n"
+ incr i
+ if {$i < $argc} {
+ if {(![getLiteral [lindex $tokens $i] string] \
+ || $string == "-")} {
+ append commands "parseWord \$tokens $i\n"
+ } else {
+ append commands "parseBody \$tokens $i\n"
+ }
+ incr i
+ }
+ }
+ }
+ }] == 1} {
+ parseCommand $tokens $index
+ } else {
+ eval $commands
+ }
+ return $i
+}
+
+# instrument::parseExpect --
+#
+# Handler for "expect" style commands.
+#
+# Arguments:
+# chainCmd The command to call once the tokens have
+# been parsed correctly.
+# tokens The list of word tokens after the initial
+# command and subcommand names
+# index The index into the token tree where the
+# parser should start.
+#
+# Results:
+# Returns the index of the next to parse.
+
+proc instrument::parseExpect {chainCmd tokens index} {
+ set end [llength $tokens]
+ set argc [expr {$end - $index}]
+
+ # The command was called with no arguments, so just return.
+
+ if {$argc < 1} {
+ return $end
+ }
+
+ # Determine which command to execute. We have four possible cases:
+ # 1. One argument which should be split into words.
+ # 2. One argument which should NOT be split into words.
+ # 3. Two arguments where the first is "-brace" and the second
+ # is the body that needs to be split into words.
+ # 4. A bunch of pattern/action pairs.
+
+ if {$argc == 1} {
+ set word [lindex $tokens $index]
+ if {![getLiteral $word body]} {
+ return [parseWord $tokens $index]
+ }
+
+ # Check to see if the body looks like a single pattern or a
+ # set of pattern/action pairs. Whitespace followed by a newline
+ # indicates that it is a pattern/action pair.
+
+ if {[regexp "(\[ \t\r\])?\n.*" $body]} {
+ set tokens [parseExpRange $tokens $index]
+ set index 0
+ }
+ } elseif {$argc == 2} {
+ # Get the switch and the body. If either are non-literal
+ # then punt and check nothing specific.
+
+ set word [lindex $tokens $index]
+ if {![getLiteral $word switch]} {
+ return [parseCommand $tokens $index]
+ }
+ set word [lindex $tokens [expr {$index + 1}]]
+ if {![getLiteral $word body]} {
+ return [parseCommand $tokens $index]
+ }
+
+ # If the switch is "-brace" increment the index so the rangeCmd
+ # is called with the index pointing to the body.
+
+ if {$switch == "-brace"} {
+ incr index
+ set tokens [parseExpRange $tokens $index]
+ set index 0
+ }
+ }
+
+ return [$chainCmd $tokens $index]
+}
+
+# instrument::parseExpRange --
+#
+# This function reparses the current token as a list of additional
+# arguments to the expect command.
+#
+# tokens The list of word tokens after the initial
+# command and subcommand names
+# index The index into the token tree where the
+# parser should start.
+#
+# Results:
+# Returns the new list of tokens to parse.
+
+proc instrument::parseExpRange {tokens index} {
+ variable script
+
+ set word [lindex $tokens $index]
+ set range [lindex $word 1]
+ set quote [string index $script [parse charindex $script $range]]
+ if {$quote == "\"" || $quote == "\{"} {
+ set range [list [expr {[lindex $range 0] + 1}] \
+ [expr {[lindex $range 1] - 2}]]
+ }
+
+ set result {}
+
+ for {} {[parse charlength $script $range] > 0} \
+ {set range $tail} {
+ # Parse the next command
+
+ if {[catch {foreach {comment cmdRange tail tree} \
+ [parse command $script $range] {}}]} {
+ # An error occurred during parsing so generate the error.
+
+ if {$instrument::errorHandler != ""} {
+ pushContext
+ setLocation [list [lindex $::errorCode 2] 1]
+ set location [getLocation]
+ popContext
+ if {[$instrument::errorHandler $location]} {
+ # Ignore the error and treat the rest of the range
+ # as a single token
+ return [list [list simple $range \
+ [list [list text $range {}]]]]
+ }
+ }
+ # Note we are bailing all the way out here, so we don't need
+ # to pop the context or do any other cleanup.
+
+ error "Unable to parse" $::errorInfo [list CAUGHT $::errorCode]
+ }
+
+ if {[parse charlength $script $cmdRange] <= 0} {
+ continue
+ }
+ eval {lappend result} $tree
+ }
+
+ return $result
+}
+
+# instrument::expMatch --
+#
+# Using the Expect style of matching, determine if the string
+# matches one of the keywords.
+#
+# Arguments:
+# keywords A list of keywords to match.
+# str The word to match.
+# minlen Minimum number of chars required to match.
+#
+# Results:
+# Return 1 if this matches or 0 if it does not.
+
+proc instrument::expMatch {keywords str minlen} {
+ set end [string length $str]
+ foreach key $keywords {
+ set m $minlen
+ for {set i 0} {$i < $end} {incr i; incr m -1} {
+ if {[string index $str $i] != [string index $key $i]} {
+ break
+ }
+ }
+ if {($i == $end) && ($m <= 0)} {
+ return 1
+ }
+ }
+ return 0
+}
+
+# instrument::parseExpectTokens --
+#
+# Parse the contents of an expect pattern/action list.
+#
+# Arguments:
+# tokens The list of word tokens after the initial
+# command and subcommand names
+# index The index into the token tree where the
+# parser should start.
+#
+# Results:
+# Returns the index of the next to parse.
+
+proc instrument::parseExpectTokens {tokens index} {
+ set argc [llength $tokens]
+ while {$index < $argc} {
+ if {![getLiteral [lindex $tokens $index] arg]} {
+ # If we have a substitution we can't tell which of the remaining
+ # arguments are patterns, switches or actions.
+
+ return [parseCommand $tokens $index]
+ }
+
+ # Check for switches.
+
+ switch -glob -- $arg {
+ "eof" -
+ "null" -
+ "default" -
+ "timeout" -
+ "full_buffer" {
+ # No-Op. This keyword is considered to be the "pattern"
+ # in the pattern/action pair. The next word is the action.
+ incr index
+ }
+ -* {
+ set arg [string range $arg 1 end]
+ if {($arg == "-") || [expMatch {glob regexp exact} $arg 2]} {
+ # The next word is a pattern followed by a command.
+
+ incr index
+ set index [parseWord $tokens $index]
+ } elseif {[expMatch {timestamp iread iwrite indices} $arg 2]} {
+ incr index
+ continue
+ } elseif {[expMatch "notransfer" $arg 1]} {
+ incr index
+ continue
+ } elseif {[expMatch "nocase" $arg 3]} {
+ incr index
+ continue
+ } elseif {$arg == "nobrace"} {
+ incr index
+ continue
+ } elseif {$arg == "i" || [expMatch "timeout" $arg 2]} {
+ # The next token is a switch argument.
+
+ incr index
+ set index [parseWord $tokens $index]
+ continue
+ } else {
+ # This is an unexpected parameter, so bail on the
+ # rest of the tokens.
+ return [parseCommand $tokens $index]
+ }
+ }
+ default {
+ # This is a pattern. Check the pattern for subcommands.
+
+ set index [parseWord $tokens $index]
+ }
+ }
+
+ # The next argument is a body.
+
+ if {$index < $argc} {
+ set index [parseBody $tokens $index]
+ }
+ }
+ return $index
+}
+
+# instrument::parseInteractTokens --
+#
+# Parse the contents of an exp_interact pattern/action list.
+#
+# Arguments:
+# tokens The list of word tokens after the initial
+# command and subcommand names
+# index The index into the token tree where the
+# parser should start.
+#
+# Results:
+# Returns the index of the next to parse.
+
+proc instrument::parseInteractTokens {tokens index} {
+ set argc [llength $tokens]
+ while {$index < $argc} {
+ if {![getLiteral [lindex $tokens $index] arg]} {
+ # If we have a substitution we can't tell which of the remaining
+ # arguments are patterns, switches or actions.
+
+ return [parseCommand $tokens $index]
+ }
+
+ # Check for switches.
+
+ switch -glob -- $arg {
+ "eof" -
+ "null" {
+ # This keyword is considered to be the "pattern"
+ # in the pattern/action pair. The next word is the action.
+ incr index
+ }
+ "timeout" {
+ # The next token is a switch argument then a body.
+ incr index
+ set index [parseWord $tokens $index]
+ }
+ -* {
+ set arg [string range $arg 1 end]
+ if {($arg == "-") \
+ || [expMatch {regexp exact} $arg 2] \
+ || ($arg == "timeout")} {
+ # The next word is a pattern or argument followed by
+ # a command.
+ incr index
+ set index [parseWord $tokens $index]
+ } elseif {$arg == "i" \
+ || [expMatch "input" $arg 2] \
+ || [expMatch "output" $arg 3] \
+ || ($arg == "u")} {
+ # The next word is the switch argument.
+
+ incr index
+ set index [parseWord $tokens $index]
+ continue
+ } elseif {[expMatch {nobuffer indices} $arg 3] \
+ || [expMatch {iread iwrite timestamp} $arg 2] \
+ || ($arg == "echo") \
+ || ($arg == "f") \
+ || ($arg == "F") \
+ || ($arg == "reset") \
+ || ($arg == "nobrace") \
+ || ($arg == "o")} {
+ # These switches take no args.
+
+ incr index
+ continue
+ } else {
+ # The next word is the command.
+
+ incr index
+ }
+ }
+ default {
+ # This is a pattern. Check the pattern for subcommands.
+
+ set index [parseWord $tokens $index]
+ }
+ }
+
+ # The next argument is a body.
+
+ if {$index < $argc} {
+ set index [parseBody $tokens $index]
+ }
+ }
+ return $index
+}
+
+# instrument::parseExpTrapCmd --
+#
+# This function parses the expect "exp_trap" and "trap" commands.
+#
+# Arguments:
+# tokens The list of word tokens.
+# index The index into the token tree where the
+# parser should start.
+#
+# Results:
+# Returns the index of the next to parse.
+
+proc instrument::parseExpTrapCmd {tokens index} {
+ set show 0
+ set argc [llength $tokens]
+ for {set i $index} {$i < $argc} {incr i} {
+ if {![getLiteral [lindex $tokens $i] arg]} {
+ break
+ }
+ switch -- $arg {
+ -code {
+ # No-Op
+ }
+ -max -
+ -name -
+ -number {
+ set show 1
+ }
+ default {
+ break
+ }
+ }
+ }
+
+ set remaining [expr {$argc - $i}]
+ if {!$show && ($remaining == 2)} {
+ return [parseSimpleArgs 2 2 {parseBody parseWord} $tokens $i]
+ }
+ return [parseCommand $tokens $i]
+}
+
--- /dev/null
+# The Tcl debugger for Speare code editor.
+# Copyright (c) 1998-2000 Ajuba Solutions
+# Copyright (c) 2019 sevenuc.com. All rights reserved.
+#
+# THIS FILE IS PART OF SPEARE CODE EDITOR. WITHOUT THE
+# WRITTEN PERMISSION OF THE AUTHOR THIS FILE MAY NOT
+# BE USED FOR ANY COMMERCIAL PRODUCT.
+#
+# More info:
+# http://sevenuc.com/en/Speare.html
+# Contact:
+# Sevenuc support <info@sevenuc.com>
+# Issue report and requests pull:
+# https://github.com/chengdu/Speare
+
+
+package provide loc 1.0
+namespace eval loc {
+ # location data type --
+ #
+ # A location encapsulates the state associated with a range of
+ # bytes within a block of code. Each location is represented by
+ # a Tcl list of the form {block line range}. The block is
+ # the block identifier for the code that contains the range.
+ # The line is the line number of the first byte in the range.
+ # The range indicates the extent of the location within the
+ # block in a form suitable for use with the parser.
+
+}
+# end namespace loc
+
+
+# loc::getBlock --
+#
+# Returns the block that contains the given location.
+# If no such location exists, an error is generated.
+#
+# Arguments:
+# location The code location whose block is returned.
+#
+# Results:
+# Returns the block that contains the given location.
+
+proc loc::getBlock {location} {
+ return [lindex $location 0]
+}
+
+
+# loc::getLine --
+#
+# Returns the line number for the start of the location as an
+# offset from the beginning of the block. If no such location
+# exists, an error is generated.
+#
+# Arguments:
+# location The code location whose line number is returned.
+#
+# Results:
+# Returns the line number for the start of the location as an
+# offset from the beginning of the block.
+
+proc loc::getLine {location} {
+ return [lindex $location 1]
+}
+
+# loc::getRange --
+#
+# Returns the range for the given location in a form suitable
+# for use with the parser interface. If no such location
+# exists, an error is generated.
+#
+# Arguments:
+# location The code location whose range is returned.
+#
+# Results:
+# Returns the range for the given location in a form suitable
+# for use with the parser interface.
+
+proc loc::getRange {location} {
+ variable locArray
+
+ return [lindex $location 2]
+}
+
+# loc::makeLocation --
+#
+# Creates a new location based on the block, range, and line values.
+# If the block is invalid, an error is generated. Either the range
+# or line must be non-empty, otherwise an error is generated.
+#
+# Arguments:
+# block The block containing the location to be created.
+# line The line number of the beginning of the location.
+# range Optional. A pair of the location's start and length
+# byte values.
+#
+# Results:
+# Returns a unique location identifier.
+
+proc loc::makeLocation {block line {range {}}} {
+ return [list $block $line $range]
+}
+
+# loc::match --
+#
+# Compare two locations to see if the second location is a match
+# for the first location. If the first location has no range, then
+# it will match all locations with the same line number. If the
+# first location has no line number, then it will match all locations
+# with the same block. Otherwise it will only match locations that
+# have exactly the same block, line and range.
+#
+# Arguments:
+# pattern The location pattern.
+# location The location to test.
+#
+# Results:
+# Returns 1 if the location matches the pattern.
+
+proc loc::match {pattern location} {
+ # Check for null line.
+ if {[lindex $pattern 1] == ""} {
+ return [expr {[string compare [lindex $pattern 0] \
+ [lindex $location 0]] == 0}]
+ }
+ # Check for null range.
+ if {[lindex $pattern 2] == ""} {
+ return [expr {[string compare [lrange $pattern 0 1] \
+ [lrange $location 0 1]] == 0}]
+ }
+ # Compare the full location.
+ return [expr {[string compare $pattern $location] == 0}]
+}
+
--- /dev/null
+# The Tcl debugger for Speare code editor.
+# Copyright (c) 1998-2000 Ajuba Solutions
+# Copyright (c) 2019 sevenuc.com. All rights reserved.
+#
+# THIS FILE IS PART OF SPEARE CODE EDITOR. WITHOUT THE
+# WRITTEN PERMISSION OF THE AUTHOR THIS FILE MAY NOT
+# BE USED FOR ANY COMMERCIAL PRODUCT.
+#
+# More info:
+# http://sevenuc.com/en/Speare.html
+# Contact:
+# Sevenuc support <info@sevenuc.com>
+# Issue report and requests pull:
+# https://github.com/chengdu/Speare
+
+
+# This file is transmitted to the client application when debugger_init
+# connects to the debugger process. It is evaluated in the debugger_Init
+# procedure scope. The local variable "socket" contains the file handle for
+# the debugger socket.
+
+global DbgNub
+global tcl_version
+set DbgNub(socket) $socket
+
+# Before we go any further, make sure the socket is in the right encoding.
+
+if {$tcl_version >= 8.1} {
+ fconfigure $socket -encoding utf-8
+}
+
+# debug flag --
+#
+# The debug flag can be any OR'ed combination of these flags:
+#
+# 0 - no debug output
+# 1 - statement logging
+# 2 - socket protocol logging
+
+if {![info exists DbgNub(debug)]} {
+ set DbgNub(debug) 0
+}
+if {![info exists DbgNub(logFile)]} {
+ set DbgNub(logFile) stderr
+}
+
+# error action flag --
+#
+# This flag controls the action taken when an error result code is detected.
+# If this flag is set to 0, errors will be allowed to propagate normally. If
+# the flag is 1, errors that would cause the program to exit will be caught
+# at the nearest instrumented statement on the stack and an error break will
+# be generated. If the flag is 2, then all errors will generate an error
+# break.
+
+set DbgNub(errorAction) 1
+
+# catch flag --
+#
+# If this flag is set, then the current error should be caught by the
+# debugger because it is not handled by the application.
+
+set DbgNub(catch) 1
+
+# handled error flag --
+#
+# If this flag is set, the current error has already been reported so it
+# should be propagated without generating further breakpoints.
+
+set DbgNub(errorHandled) 0
+
+# exclude commands list --
+#
+# This is a list of all commands, used in the nub, that will cause
+# the debugger to crash if they are renamed. In the wrapped rename
+# procedure, the command being renamed is compared to this list. If
+# the command is on this list, then an error is generated stating
+# that renaming the command will crash the debugger.
+
+set DbgNub(excludeRename) [list append array break cd close concat continue \
+ eof error eval expr fconfigure file fileevent flush for foreach gets \
+ global if incr info lappend lindex linsert list llength lrange \
+ lreplace lsearch namespace open puts pwd read regexp regsub rename \
+ return set string switch trace unset uplevel upvar variable \
+ vwait while]
+
+# wrapped commands list --
+#
+# This is a list of commands that the nub has wrapped. The names may
+# change during runtime due to the "rename" command. However, the nub
+# filters for "info proc" will always treat these as "commands".
+
+set DbgNub(wrappedCommandList) [list catch source update uplevel \
+ vwait info package proc rename]
+
+# instruction nesting count --
+#
+# Records the number of nested instrumented instructions on the
+# stack. This count is reset whenever a new event loop frame is pushed.
+# It is used for determining when an error has propagated to the global
+# scope.
+
+set DbgNub(nestCount) 0
+
+# subcommand nesting count --
+#
+# Records the number of nested command substitutions in progress. This count
+# is used to determine where step-over operations should break. The
+# currentCmdLevel records the nesting level of the currently executing
+# statement. The stepCmdLevel records the nesting level of the last step
+# command.
+
+set DbgNub(currentCmdLevel) 0
+set DbgNub(stepCmdLevel) 0
+
+# step context level --
+#
+# Records the level at which the current "step over" or "step out" operation
+# was initiated.
+
+set DbgNub(stepLevel) 0
+set DbgNub(stepOutLevel) {}
+
+# break next flag --
+#
+# If this flag is set, the next instrumented statement will trigger a
+# breakpoint. This flag is set when single-stepping or when an inc interrupt
+# has been received.
+
+set DbgNub(breakNext) 1
+
+# breakpoint check list --
+#
+# Contains a list of commands to invoke when testing whether to break on a
+# given statement. Each command is passed a location and the current level.
+# The breakPreChecks list is invoked before a statement executes.
+
+set DbgNub(breakPreChecks) {}
+set DbgNub(breakPostChecks) {}
+
+# breakpoint location tests --
+#
+# For each location that contains a breakpoint, there is an entry in the
+# DbgNub array that contains a list of test scripts that will be evaluated at
+# the statement scope. If the test script returns 1, a break will be
+# triggered. The format of a breakpoint record is DbgNub(<block>:<line>).
+# The numBreaks field records the number of active breakpoints.
+
+set DbgNub(numBreaks) 0
+
+# variable trace counter --
+#
+# Each variable trace is referred to by a unique identifier. The varHandle
+# counter contains the last trace handle that was allocated. For each trace
+# there is a list of active variable breakpoints stored as a list in
+# DbgNub(var:<handle>). For each variable breakpoint created in the
+# debugger, the reference count in dbgNub(varRefs:<handle>) is incremented.
+
+set DbgNub(varHandle) 0
+
+# instruction stack --
+#
+# Records the location information associated with each instrumented
+# statement currently being executed. The current context is a list of
+# the form {level type ?arg1 ... argn?}. The level indicates
+# the scope in which the statement is executing. The type is one of
+# "proc", "source", or "global" and indicates where the statement came
+# from. For "proc" frames, the args contain the name of the
+# procedure and its declared arguments. For "source" frames, the args
+# contain the name of the file being sourced. The locations field
+# contains a list of statement locations indicating nested calls to
+# Tcl_Eval at the same scope (e.g. while). Whenever a new context is
+# created, the previous context and location list are pushed onto the
+# contextStack. New frames are added to the end of the list.
+
+set DbgNub(contextStack) {}
+set DbgNub(context) {0 global}
+set DbgNub(locations) {}
+
+# call stack --
+#
+# Records the Tcl call stack as reported by info level. The stack is a
+# list of context records as described for instruction stack entries.
+
+set DbgNub(stack) {{0 global}}
+
+# instrumentation flags --
+#
+# The first three flags are set by user preferences:
+# dynProc - if true, dynamic procs should be instrumented
+# autoLoad - if false, all files sourced during an auto_load,
+# auto_import, or package require operation should not
+# be instrumented. Dynamic procedures will not be
+# defined, either.
+# includeFiles - contains a list of string match patterns that
+# must be matched in order for sourced files to be
+# instrumented. Only the specific file matched
+# and any procedures it defines will be included, not
+# files that it sources. Exclusion (below) takes
+# precedence over inclusion.
+# excludeFiles - contains a list of string match patterns that
+# will be used to exclude some sourced files from
+# instrumentation. Only the specific file matched
+# and any procedures it defines will be excluded, not
+# files that it sources. Exclusion takes precedence
+# over inclusion (above).
+#
+# The next three flags are used to keep track of any autoloads, package
+# requires or excluded files that are in progress.
+
+set DbgNub(dynProc) 0
+set DbgNub(autoLoad) 1
+set DbgNub(excludeFiles) {}
+set DbgNub(includeFiles) {*}
+
+set DbgNub(inAutoLoad) 0
+set DbgNub(inExclude) 0
+set DbgNub(inRequire) 0
+
+# code coverage variables --
+#
+# DbgNub(cover:*) - hash table of covered locations
+# DbgNub(cover) - if true, store coverage info for each call to
+# DbgNub_Do, and send coverage info to debugger
+# on each break.
+
+set DbgNub(cover) 0
+
+# info script: We need to keep track of the current script being
+# sourced so that "info script" can return the current result. The
+# following variable is a stack of all sourced files. The initial value must
+# be set for the remote debugging case, as the script is not neccessarily
+# sourced. For the local debugging case, the initial value is temporarily
+# appLaunch.tcl, which is not correct, but this value will never be accessed
+# because the "initial" script will be sourced, thereby pushing the correct
+# script name on the stack.
+
+set DbgNub(script) [list [info script]]
+
+# Tcl 8.0 & namespace command
+#
+# This variable tells the various Nub functions whether to deal
+# with namespace issues that are part of Tcl 8.0. The namespace
+# issues may also be present in version less than Tcl 8.0 that
+# have itcl - this is a very different type of namespace, however.
+# We also set a scope prefix that will be used on every command that
+# we invoke in an uplevel context to ensure that we get the global version of
+# the command instead of a namespace local version.
+
+if {[info tclversion] >= 8.0} {
+ set DbgNub(namespace) 1
+ set DbgNub(itcl76) 0
+ set DbgNub(scope) ::
+} else {
+ set DbgNub(namespace) 0
+ if {[info commands "namespace"] == "namespace"} {
+ set DbgNub(itcl76) 1
+ } else {
+ set DbgNub(itcl76) 0
+ }
+ set DbgNub(scope) {}
+}
+
+# cached result values --
+#
+# After every instrumented statement, the nub stores the current return code
+# and result value.
+
+set DbgNub(lastCode) 0
+set DbgNub(lastResult) {}
+
+##############################################################################
+
+
+# DbgNub_Startup --
+#
+# Initialize the nub state by wrapping commands and creating the
+# socket event handler.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc DbgNub_Startup {} {
+ global DbgNub errorInfo errorCode
+
+ DbgNub_WrapCommands
+
+ if {![DbgNub_infoCmd exists errorInfo]} {
+ set errorInfo {}
+ }
+ if {![DbgNub_infoCmd exists errorCode]} {
+ set errorCode {}
+ }
+
+ #puts "DbgNub_Startup(): $DbgNub(socket)"
+
+ fileevent $DbgNub(socket) readable DbgNub_SocketEvent
+ DbgNub_ProcessMessages 1
+ return
+}
+
+# DbgNub_Shutdown --
+#
+# Terminate communication with the debugger.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc DbgNub_Shutdown {} {
+ global DbgNub
+ if {$DbgNub(socket) != -1} {
+ close $DbgNub(socket)
+ set DbgNub(socket) -1
+ }
+}
+
+# DbgNub_SendMessage --
+#
+# Send the given script to be evaluated in the server.
+#
+# Arguments:
+# script The script to be evaluated.
+#
+# Results:
+# None.
+
+proc DbgNub_SendMessage {args} {
+ global DbgNub
+ if {$DbgNub(socket) == -1} {
+ return
+ }
+ puts $DbgNub(socket) [string length $args]
+ puts -nonewline $DbgNub(socket) $args
+
+ if {$DbgNub(debug) & 2} {
+ DbgNub_Log "sending [string length $args] bytes: '$args'"
+ }
+ if {[DbgNub_catchCmd {flush $DbgNub(socket)}]} {
+ if {$DbgNub(debug) & 2} {
+ DbgNub_Log "SendMessage detected closed socket"
+ }
+ DbgNub_Shutdown
+ }
+ return
+}
+
+# DbgNub_GetMessage --
+#
+# Get the next message from the debugger.
+#
+# Arguments:
+# blocking If 1, wait until a message is detected (or eof),
+# otherwise check without blocking,
+#
+# Results:
+# Returns the message that was received, or {} no message was
+# present.
+
+proc DbgNub_GetMessage {blocking} {
+ global DbgNub
+
+ if {$DbgNub(socket) == -1} {
+ return ""
+ }
+
+ # Put the socket into non-blocking mode long enough to poll if
+ # we aren't doing a blocking read.
+
+ fconfigure $DbgNub(socket) -blocking $blocking
+ set result [gets $DbgNub(socket) bytes]
+ fconfigure $DbgNub(socket) -blocking 1
+ if {$result == -1} {
+ return ""
+ }
+
+ set msg [read $DbgNub(socket) $bytes]
+ if {$DbgNub(debug) & 2} {
+ DbgNub_Log "got: '$msg'"
+ }
+ return $msg
+}
+
+# DbgNub_SocketEvent --
+#
+# This function is called when a message arrives from the debugger during
+# an event loop.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc DbgNub_SocketEvent {} {
+ global DbgNub
+
+ DbgNub_ProcessMessages 0
+ if {$DbgNub(breakNext)} {
+ DbgNub_Break 0 linebreak
+ }
+}
+
+# DbgNub_Do --
+#
+# Execute an instrumented statement. This command is used to
+# prefix all instrumented statements. It will detect any
+# uncaught errors and ask the debugger how to handle them.
+# All other errors will be propagated.
+#
+# Arguments:
+# subcommand 1 if this statement is part of a command substitution,
+# 0 if this statement is a body statement.
+# location Location in original code block that
+# corresponds to the current statement.
+# args The script that should be executed.
+#
+# Results:
+# Returns the result of executing the script.
+
+proc DbgNub_Do {subcommand location cmd} {
+ global DbgNub errorInfo errorCode
+
+
+ if {$DbgNub(socket) == -1} {
+ set code [DbgNub_catchCmd {DbgNub_uplevelCmd 1 $cmd} result options]
+ array set optsArray $options
+ array unset optsArray -code
+ array unset optsArray -errorcode
+ array unset optsArray -errorinfo
+ array unset optsArray -level
+ return -code $code -errorcode $errorCode -errorinfo $errorInfo -options [array get optsArray] $result
+ }
+
+ set level [expr {[DbgNub_infoCmd level] - 1}]
+
+ # Push a new virtual stack frame so we know where we are
+
+ lappend DbgNub(locations) $location
+ incr DbgNub(nestCount)
+
+ # If this command is part of a command substitution, increment the
+ # subcommand level.
+
+ if {$subcommand} {
+ incr DbgNub(currentCmdLevel)
+ }
+
+ if {$DbgNub(debug) & 1} {
+ DbgNub_Log "[list DbgNub_Do $subcommand $location $cmd]"
+ }
+
+ # Process any queued messages without blocking
+
+ DbgNub_ProcessMessages 0
+
+ # Check to see if we need to stop on this statement
+
+ if {! $DbgNub(breakNext)} {
+ foreach check $DbgNub(breakPreChecks) {
+ if {[$check $location $level]} {
+ set DbgNub(breakNext) 1
+ break
+ }
+ }
+ }
+ if {$DbgNub(breakNext)} {
+ DbgNub_Break $level linebreak
+ }
+
+ # Execute the statement and return the result
+
+ set DbgNub(lastCode) [DbgNub_catchCmd {DbgNub_uplevelCmd 1 $cmd} \
+ DbgNub(lastResult) options]
+ array set optsArray $options
+ array unset optsArray -code
+ array unset optsArray -errorcode
+ array unset optsArray -errorinfo
+ array unset optsArray -level
+
+ # Store the current location in DbgNub array, so we can calculate which
+ # locations have not yet been covered.
+
+ if {$DbgNub(cover)} {
+ set index "cover:$location"
+ if {[info exists DbgNub($index)]} {
+ incr DbgNub($index)
+ } else {
+ set DbgNub($index) 1
+ }
+ }
+
+ if {$DbgNub(debug) & 1} {
+ DbgNub_Log "[list DbgNub_Do $subcommand $location $cmd completed \
+ with code == $DbgNub(lastCode)]"
+ }
+ if {$DbgNub(lastCode) == 1} {
+ # Clean up the errorInfo stack to remove our tracks.
+ DbgNub_cleanErrorInfo
+ DbgNub_cleanWrappers
+
+ # This error could end the application. Let's check
+ # to see if we want to stop and maybe break now.
+ if {! $DbgNub(errorHandled) && (($DbgNub(errorAction) == 2) \
+ || (($DbgNub(errorAction) == 1) && $DbgNub(catch)))} {
+ if {[DbgNub_HandleError $DbgNub(lastResult) $level]} {
+ set DbgNub(lastCode) 0
+ set DbgNub(lastResult) {}
+ set errorCode NONE
+ set errorInfo {}
+ set DbgNub(errorHandled) 0
+ if {[DbgNub_infoCmd exists DbgNub(returnState)]} {
+ unset DbgNub(returnState)
+ }
+ } else {
+ set DbgNub(errorHandled) 1
+ }
+ }
+ }
+ # Check to see if we need to stop and display the command result.
+ set breakAfter 0
+ foreach check $DbgNub(breakPostChecks) {
+ if {[$check $location $level]} {
+ set breakAfter 1
+ break
+ }
+ }
+ if {$breakAfter} {
+ DbgNub_Break $level cmdresult
+ }
+
+ # Pop the current location from the location stack
+ set DbgNub(locations) [lreplace $DbgNub(locations) end end]
+
+ incr DbgNub(nestCount) -1
+ if {$DbgNub(nestCount) == 0} {
+ set DbgNub(errorHandled) 0
+ }
+
+ # Pop the subcommand frame, if necessary.
+
+ if {$subcommand} {
+ incr DbgNub(currentCmdLevel) -1
+ }
+
+ set optsDict [dict create -errorinfo $errorInfo -errorcode $errorCode -options [array get optsArray]]
+ set optsDict [dict filter $optsDict value ?*]
+ return -code $DbgNub(lastCode) {*}$optsDict $DbgNub(lastResult)
+}
+
+# DbgNub_Break --
+#
+# Generate a breakpoint notification and wait for the debugger
+# to tell us to continue.
+#
+# Arguments:
+# level The level of the program counter.
+# type The type of breakpoint being generated.
+# args Additonal type specific arguments.
+#
+# Results:
+# None.
+
+proc DbgNub_Break {level type args} {
+ set marker [DbgNub_PushStack $level]
+ DbgNub_SendMessage BREAK [DbgNub_CollateStacks] [DbgNub_GetCoverage] \
+ $type $args
+ DbgNub_ProcessMessages 1
+ DbgNub_PopStack $marker
+}
+
+# DbgNub_Run --
+#
+# Configure the nub to start running again. The given operation
+# will determine how far the debugger will run.
+#
+# Arguments:
+# op The type of step operation to do.
+#
+# Results:
+# None. However, the application will start running again.
+
+proc DbgNub_Run {{op run}} {
+ global DbgNub
+
+ # Remove any stale check procedures
+
+ set index [lsearch -exact $DbgNub(breakPreChecks) DbgNub_CheckOver]
+ if {$index != -1} {
+ set DbgNub(breakPreChecks) \
+ [lreplace $DbgNub(breakPreChecks) $index $index]
+ }
+ set index [lsearch -exact $DbgNub(breakPostChecks) DbgNub_CheckOver]
+ if {$index != -1} {
+ set DbgNub(breakPostChecks) \
+ [lreplace $DbgNub(breakPostChecks) $index $index]
+ }
+ set DbgNub(stepOutLevel) {}
+
+ switch $op {
+ any {
+ set DbgNub(breakNext) 1
+ }
+ over {
+ lappend DbgNub(breakPreChecks) DbgNub_CheckOver
+ set DbgNub(stepLevel) [llength $DbgNub(contextStack)]
+ set DbgNub(stepCmdLevel) $DbgNub(currentCmdLevel)
+ set DbgNub(breakNext) 0
+ }
+ out {
+ set DbgNub(stepOutLevel) [llength $DbgNub(contextStack)]
+ set DbgNub(breakNext) 0
+ }
+ cmdresult {
+ lappend DbgNub(breakPostChecks) DbgNub_CheckOver
+ set DbgNub(stepLevel) [llength $DbgNub(contextStack)]
+ set DbgNub(stepCmdLevel) $DbgNub(currentCmdLevel)
+ set DbgNub(breakNext) 0
+ }
+ default {
+ set DbgNub(breakNext) 0
+ }
+ }
+ set DbgNub(state) running
+}
+
+# DbgNub_CheckOver --
+#
+# Checks to see if we should break the debugger based on what
+# level we are located in.
+#
+# Arguments:
+# location Current location.
+# level Stack level of current statement.
+#
+# Results:
+# Returns 1 if we should break at this statement.
+
+proc DbgNub_CheckOver {location level} {
+ global DbgNub
+
+ set curLevel [llength $DbgNub(contextStack)]
+
+ if {($curLevel < $DbgNub(stepLevel)) \
+ || ($DbgNub(currentCmdLevel) < $DbgNub(stepCmdLevel)) \
+ || (($curLevel == $DbgNub(stepLevel)) \
+ && ($DbgNub(currentCmdLevel) == $DbgNub(stepCmdLevel)))} {
+ set index [lsearch -exact $DbgNub(breakPreChecks) DbgNub_CheckOver]
+ if {$index != -1} {
+ set DbgNub(breakPreChecks) \
+ [lreplace $DbgNub(breakPreChecks) $index $index]
+ }
+ return 1
+ }
+ return 0
+}
+
+# DbgNub_HandleError --
+#
+# Notify the debugger that an uncaught error has occurred and
+# wait for it to tell us what to do.
+#
+# Arguments:
+# message Error message reported by statement.
+# level Level at which the error occurred.
+#
+# Results:
+# Returns 1 if the error should be ignored, otherwise
+# returns 0.
+
+proc DbgNub_HandleError {message level} {
+ global DbgNub errorInfo errorCode
+ set DbgNub(ignoreError) 0
+ DbgNub_Break $level error $message $errorInfo $errorCode $DbgNub(catch)
+ return $DbgNub(ignoreError)
+}
+
+# DbgNub_Instrument --
+#
+# Pass a block of code to the debugger to be instrumented.
+# Generates an INSTRUMENT message that will eventually be
+# answered with a call to DbgNub_InstrumentReply.
+#
+# Arguments:
+# file Absolute path to file being instrumented.
+# script Script being instrumented.
+#
+# Results:
+# Returns the instrumented form of the script, or "" if the
+# script was not instrumentable.
+
+proc DbgNub_Instrument {file script} {
+ global DbgNub
+
+ # Send the code to the debugger and process events until we are
+ # told to continue execution. The instrumented code should be
+ # contained in the global DbgNub array.
+
+ set DbgNub(iscript) ""
+ DbgNub_SendMessage INSTRUMENT $file $script
+ DbgNub_ProcessMessages 1
+ return $DbgNub(iscript)
+}
+
+# DbgNub_InstrumentReply --
+#
+# Invoked when the debugger completes instrumentation of
+# code sent in a previous INSTRUMENT message.
+#
+# Arguments:
+# script The instrumented script.
+#
+# Results:
+# None. Stores the instrumented script in DbgNub(iscript) and
+# sets the DbgNub(state) back to running so we break out of the
+# processing loop.
+
+proc DbgNub_InstrumentReply {script} {
+ global DbgNub
+ set DbgNub(iscript) $script
+ set DbgNub(state) running
+
+
+# FIXME: change this state by yeung
+# set DbgNub(state) stopped
+
+}
+
+
+# DbgNub_UninstrumentProc --
+#
+# Give a fully qualified procedure name and the orginal proc
+# body (before it was instrumented) this procedure will recreate
+# the procedure to effectively unimplement the procedure.
+#
+# Arguments:
+# procName A fully qualified procedure name.
+# body The uninstrumented version of the body.
+#
+# Results:
+# None - various global state about the proc is changed.
+
+proc DbgNub_UninstrumentProc {procName body} {
+ global DbgNub
+
+ set current [DbgNub_GetProcDef $procName]
+ set new [lreplace $current 0 0 DbgNub_procCmd]
+ set new [lreplace $new 3 3 $body]
+ eval $new
+ unset DbgNub(proc=$procName)
+}
+
+# DbgNub_InstrumentProc --
+#
+# Given a fully qualified procedure name this command will
+# instrument the procedure. This should not be called on
+# procedures that have already been instrumented.
+#
+# Arguments:
+# procName A fully qualified procedure name.
+#
+# Results:
+# None - various global state about the proc is changed.
+
+proc DbgNub_InstrumentProc {procName script} {
+ global DbgNub
+
+ # If the proc given has been compiled with TclPro Compiler
+ # the we can't instrument the code so we don't allow it to
+ # happen.
+
+ set cmpBody {# Compiled -- no source code available}
+ append cmpBody \n
+ append cmpBody {error "called a copy of a compiled script"}
+ if {[DbgNub_infoCmd body $procName] == $cmpBody} {
+ return
+ }
+
+ # The code we just received starts with a DbgNub_Do which we
+ # don't want to run. Strip out the actual proc command and eval.
+ set cmd [lindex $script end]
+ eval $cmd
+ return
+}
+
+# DbgNub_ProcessMessages --
+#
+# Read messages from the debugger and handle them until the
+# debugger indicates that the nub should exit the loop by setting
+# the DbgNub(state) variable to something other than "waiting".
+#
+# Arguments:
+# blocking Indicates whether we should wait for
+# messages if none are present.
+#
+# Results:
+# None. Processing certain message types may have arbitrary
+# side effects which the caller may expect.
+
+proc DbgNub_ProcessMessages {blocking} {
+ global DbgNub
+
+ if {$DbgNub(socket) == -1} {
+ #puts "DbgNub_ProcessMessages socket is nil"
+ exit 1
+ return
+ }
+
+ set DbgNub(state) waiting
+
+ while {$DbgNub(state) == "waiting"} {
+ if {[DbgNub_catchCmd {DbgNub_GetMessage $blocking} msg]} {
+ DbgNub_Shutdown
+ return
+ } elseif {$msg == ""} {
+ if {[eof $DbgNub(socket)]} {
+ DbgNub_Shutdown
+ }
+ return
+ }
+ switch [lindex $msg 0] {
+ SEND {
+ # Evaluate a Send. Return any result
+ # including error information.
+
+ set code [DbgNub_catchCmd {eval [lindex $msg 2]} result]
+ if {$code != 0} {
+ global errorInfo errorCode
+ DbgNub_SendMessage ERROR $result $code $errorCode \
+ $errorInfo
+ } elseif {[lindex $msg 1] == "1"} {
+ DbgNub_SendMessage RESULT $result
+ }
+ }
+ }
+ }
+ return
+}
+
+# DbgNub_Log --
+#
+# Log a debugging message.
+#
+# Arguments:
+# args Debugging message to log
+#
+# Results:
+# None.
+
+proc DbgNub_Log {args} {
+ global DbgNub
+ puts $DbgNub(logFile) [concat "LOG: " $args]
+ flush $DbgNub(logFile)
+}
+
+# DbgNub_GetProcs --
+#
+# Returns a list of all procedures in the application, excluding
+# those added by the debugger itself. The list consists of
+# elements of the form {<procname> <location>}, where the
+# location refers to the entire procedure definition. If the
+# procedure is uninstrumented, the location is null.
+#
+# Arguments:
+# namespace: This variable is only used by the implementation
+# of DbgNub_GetProcs itself. It is used to recurse
+# through the namespaces to find hidden procs.
+#
+# Results:
+# Returns a list of all procedures in the application, excluding
+# those added by the debugger itself and imported names. The list
+# consists of elements of the form {<procname> <location>}.
+
+proc DbgNub_GetProcs {{namespace {}}} {
+ global DbgNub
+
+ set procList ""
+ if {$namespace != ""} {
+ set nameProcs ""
+ # Be sure to call the "wrapped" version of info to filter DbgNub procs
+ foreach x [namespace eval $namespace "$DbgNub(scope)info procs"] {
+ if {[string compare \
+ [namespace eval $namespace \
+ [list $DbgNub(scope)namespace origin $x]] \
+ [namespace eval $namespace \
+ [list $DbgNub(scope)namespace which $x]]] \
+ == 0} {
+ lappend nameProcs ${namespace}::$x
+ }
+ }
+ foreach n [namespace children $namespace] {
+ set nameProcs [concat $nameProcs [DbgNub_GetProcs $n]]
+ }
+ return $nameProcs
+ } elseif {$DbgNub(namespace)} {
+ foreach n [namespace children ::] {
+ set procList [concat $procList [DbgNub_GetProcs $n]]
+ }
+ # Be sure to call the "wrapped" version of info to filter DbgNub procs
+ foreach name [$DbgNub(scope)info procs] {
+ if {[string compare [namespace origin $name] \
+ [namespace which $name]] == 0} {
+ lappend procList "::$name"
+ }
+ }
+ } else {
+ # Be sure to call the "wrapped" version of info to filter DbgNub procs
+ set procList [$DbgNub(scope)info procs]
+ }
+
+ set result {}
+ foreach name $procList {
+ if {[DbgNub_infoCmd exists DbgNub(proc=$name)]} {
+ lappend result [list $name $DbgNub(proc=$name)]
+ } else {
+ lappend result [list $name {}]
+ }
+ }
+ return $result
+}
+
+# DbgNub_GetVariables --
+#
+# Retrieve the names of the variables that are visible at the
+# specified level, excluding internal Debugger variables.
+#
+# Arguments:
+# level Stack level to get variables from.
+# vars A list of variables to test for existence. If this list
+# is null, all local and namespace variables will be returned.
+#
+# Results:
+# Returns a list of variable names.
+
+proc DbgNub_GetVariables {level vars} {
+ global DbgNub
+
+ # We call the "wrapped" version of info vars which will weed
+ # out any debugger variables that may exist in the var frame.
+
+ if {$vars == ""} {
+ set vars [DbgNub_uplevelCmd #$level "$DbgNub(scope)info vars"]
+ if {$DbgNub(itcl76)} {
+ if {[DbgNub_uplevelCmd \#$level {info which info}] \
+ == "::itcl::builtin::info"} {
+ # We are in a class or instance context
+ set name [DbgNub_uplevelCmd \#$level {lindex [info level 0] 0}]
+ set mvars [DbgNub_uplevelCmd \#$level {info variable}]
+ if {($name != "") && ([DbgNub_uplevelCmd \#$level \
+ [list info function $name -type]] == "proc")} {
+ # We are in a class proc, so we need to filter out
+ # all of the instance variables. Note that we also
+ # need to filter out duplicates because once they have
+ # been accessed once, member variables show up in the
+ # "info vars" list.
+
+ foreach var $mvars {
+ if {([DbgNub_uplevelCmd \#$level \
+ [list info variable $var -type]] == "common") \
+ && ([lsearch $vars $var] == -1)} {
+ lappend vars $var
+ }
+ }
+ } else {
+ # Filter out duplicates.
+
+ foreach var $mvars {
+ if {[lsearch $vars $var] == -1} {
+ lappend vars $var
+ }
+ }
+ }
+ }
+ } elseif {$DbgNub(namespace)} {
+ # Check to see if we are in an object or class context. In this
+ # case we need to add in the member variables. Otherwise, check
+ # to see if we are in a non-global namespace context, in which
+ # case we add the namespace variables.
+
+ if {[DbgNub_uplevelCmd \#$level \
+ [list $DbgNub(scope)namespace origin info]] \
+ == "::itcl::builtin::info"} {
+ # If the function name is null, we're in a configure context,
+ # otherwise we need to check the function type to determine
+ # whether the function is a proc or a method.
+
+ set name [DbgNub_uplevelCmd \#$level {lindex [info level 0] 0}]
+ set mvars [DbgNub_uplevelCmd \#$level {info variable}]
+ if {($name != "") && ([DbgNub_uplevelCmd \#$level \
+ [list info function $name -type]] == "proc")} {
+ # We are in a class proc, so filter out instance variables
+
+ foreach var $mvars {
+ if {[DbgNub_uplevelCmd \#$level \
+ [list info variable $var -type]] == "common"} {
+ lappend vars $var
+ }
+ }
+ } else {
+ set vars [concat $mvars $vars]
+ }
+ } else {
+ set current [DbgNub_uplevelCmd #$level \
+ "$DbgNub(scope)namespace current"]
+ if {$current != "::"} {
+ set vars [concat $vars \
+ [DbgNub_uplevelCmd #$level \
+ "$DbgNub(scope)info vars" [list ${current}::*]]]
+ }
+ }
+ }
+ }
+
+ # Construct a list of name/type pairs.
+
+ set result {}
+ foreach var $vars {
+ # We have to be careful because we cannot call
+ # upvar on a qualified namespace variable. First
+ # verify the var exists, then test to see if
+ # it is an array.
+
+ if {[DbgNub_uplevelCmd #$level [list info exists $var]]} {
+ upvar #$level $var local
+ if {[array exists local]} {
+ lappend result [list $var a]
+ } else {
+ lappend result [list $var s]
+ }
+ } else {
+ lappend result [list $var s]
+ }
+ }
+ return $result
+}
+
+# DbgNub_GetVar --
+#
+# Returns a list containing information about each of the
+# variables specified in varList. The returned list consists of
+# elements of the form {<name> <type> <value>}. Type indicates
+# if the variable is scalar or an array and is either "s" or
+# "a". If the variable is an array, the result of an array get
+# is returned for the value, otherwise it is the scalar value.
+# Any names that were specified in varList but are not valid
+# variables will be omitted from the returned list.
+#
+# Arguments:
+# level The stack level of the variables in varList.
+# maxlen The maximum length of data to return for a single
+# element. If this value is -1, the entire string
+# is returned.
+# varList A list of variables whose information is returned.
+#
+# Results:
+# Returns a list containing information about each of the
+# variables specified in varList. The returned list consists of
+# elements of the form {<name> <type> <value>}.
+
+proc DbgNub_GetVar {level maxlen varList} {
+ global DbgNub
+ set result {}
+ # Adjust the maxlen to be the last character position
+ if {$maxlen > 0} {
+ incr maxlen -1
+ }
+ foreach var $varList {
+ upvar #$level $var local
+
+ # Remove all traces before getting the value so we don't enter
+ # instrumented code or cause other undesired side effects. Note
+ # that we must do this before calling info exists, since that will
+ # also trigger a read trace.
+ #
+ # There are two types of traces to look out for: scalar and array.
+ # Array elements trigger both scalar and array traces. The current
+ # solution is a hack because we are looking for variables that look
+ # like name(element). This won't catch array elements that have been
+ # aliased with upvar to scalar names. The only way to handle that case
+ # is to wrap upvar and track every alias. This is a lot of work for a
+ # very unusual case, so we are punting for now.
+
+ set traces [trace vinfo local]
+ foreach trace $traces {
+ eval trace vdelete local $trace
+ }
+ # We use the odd string range call instead of string index
+ # to work on 8.0
+ if {[string range $var end end] == ")"} {
+ set avar [lindex [split $var "("] 0]
+ upvar #$level $avar alocal
+
+ set atraces [trace vinfo alocal]
+ foreach trace $atraces {
+ eval trace vdelete alocal $trace
+ }
+ } else {
+ set atraces {}
+ }
+
+ # Now it is safe to check for existence before we attempt to fetch the
+ # value.
+
+ if {[DbgNub_uplevelCmd #$level \
+ [list DbgNub_infoCmd exists $var]]} {
+
+ # Fetch the current value. Note that we have to be careful
+ # when truncating the value. If we call string range directly
+ # the object will be converted to a string object, losing any
+ # internal rep. If we copy it first, we can avoid the problem.
+ # Normally this doesn't matter, but for extensions like TclBlend
+ # that rely on the internal rep to control object lifetime, it
+ # is a critical step.
+
+ # Also, because of a bug in Windows where null values in the env
+ # array are automatically unset, we need to guard against
+ # non-existent values when iterating over array names. Bug: 4120
+
+ if {$maxlen == -1} {
+ if {[array exists local]} {
+ set value {}
+ foreach name [array names local] {
+ if {[DbgNub_infoCmd exists local($name)]} {
+ lappend value $name $local($name)
+ } else {
+ lappend value $name {}
+ }
+ }
+ lappend result [list $var a $value]
+ } else {
+ lappend result [list $var s $local]
+ }
+ } else {
+ if {[array exists local]} {
+ set value {}
+ foreach name [array names local] {
+ set copy {}
+ if {[DbgNub_infoCmd exists local($name)]} {
+ append copy $local($name)
+ } else {
+ append copy {}
+ }
+ lappend value $name [string range $copy 0 $maxlen]
+ }
+ lappend result [list $var a $value]
+ } else {
+ set copy {}
+ append copy $local
+ lappend result [list $var s [string range $copy 0 $maxlen]]
+ }
+ }
+
+ }
+
+ # Restore the traces
+
+ foreach trace $traces {
+ eval trace variable local $trace
+ }
+ foreach trace $atraces {
+ eval trace variable alocal $trace
+ }
+ }
+ return $result
+}
+
+# DbgNub_SetVar --
+#
+# Sets the value of a variable. If the variable is an array,
+# the value must be suitable for array set, or an error is
+# generated. If no such variable exists, an error is generated.
+# Generates an error if the application is not currently stopped.
+#
+# Arguments:
+# level The stack level of the variable to set.
+# var The name of the variable to set.
+# value The new value of var.
+#
+# Results:
+# Returns an empty string.
+
+proc DbgNub_SetVar {level var value} {
+ upvar #$level $var local
+ if {![DbgNub_infoCmd exists local]} {
+ error "No such variable $var"
+ }
+ if {[array exists local]} {
+ foreach name [array names local] {
+ unset local($name)
+ }
+ array set local $value
+ } else {
+ set local $value
+ }
+ return
+}
+
+# DbgNub_GetResult --
+#
+# Gets the last reported return code and result value.
+#
+# Arguments:
+# maxlen The maximum length of data to return for the
+# result. If this value is -1, the entire string
+# is returned, otherwise long values are truncated
+# after maxlen bytes.
+#
+# Results:
+# Returns a list of the form {code result}.
+
+proc DbgNub_GetResult {maxlen} {
+ global DbgNub
+
+ if {$maxlen == -1} {
+ set maxlen end
+ } else {
+ incr maxlen -1
+ }
+
+ return [list $DbgNub(lastCode) \
+ [string range $DbgNub(lastResult) 0 $maxlen]]
+}
+
+# DbgNub_PushContext --
+#
+# Push the current context and location stack onto the context
+# stack and set up a new context.
+#
+# Arguments:
+# level The new stack level.
+# type The context type.
+# args Context type specific state.
+#
+# Results:
+# None.
+
+proc DbgNub_PushContext {level type args} {
+ global DbgNub
+ lappend DbgNub(contextStack) [list $DbgNub(context) $DbgNub(locations)]
+ set DbgNub(locations) {}
+ set DbgNub(context) [concat $level $type $args]
+ if {$DbgNub(debug) & 1} {
+ DbgNub_Log "PUSH CONTEXT:\ncontext = $DbgNub(context)\n\locations = $DbgNub(locations)\ncontextStack = $DbgNub(contextStack)\nstack=$DbgNub(stack)"
+ }
+ return
+}
+
+# DbgNub_PopContext --
+#
+# Restore the previous context from the contextStack.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc DbgNub_PopContext {} {
+ global DbgNub
+ set last [lindex $DbgNub(contextStack) end]
+ set DbgNub(contextStack) [lreplace $DbgNub(contextStack) end end]
+ set DbgNub(context) [lindex $last 0]
+ set DbgNub(locations) [lindex $last 1]
+ if {$DbgNub(debug) & 1} {
+ DbgNub_Log "POP CONTEXT:\ncontext = $DbgNub(context)\n\locations = $DbgNub(locations)\ncontextStack = $DbgNub(contextStack)\nstack=$DbgNub(stack)"
+ }
+ return
+}
+
+# DbgNub_PushStack --
+#
+# Push info about all of the stack frames that have been
+# added after the last stack checkpoint.
+#
+# Arguments:
+# current Stack level of current statement.
+# frame Optional. New stack frame that will be pushed
+# by current statement.
+#
+# Results:
+# Returns a marker for the end of the stack before any frames
+# were pushed.
+
+proc DbgNub_PushStack {current {frame {}}} {
+ global DbgNub
+
+ set oldTop [lindex [lindex $DbgNub(stack) end] 0]
+ set marker [expr {[llength $DbgNub(stack)] - 1}]
+
+ for {set level [expr {$oldTop + 1}]} {$level <= $current} {incr level} {
+ set name [lindex [DbgNub_infoCmd level $level] 0]
+ if {$name == ""} {
+ # This is a "namespace eval" so compute the name and push
+ # it onto the stack.
+ if {$DbgNub(itcl76)} {
+ set name [DbgNub_uplevelCmd \#$level \
+ [list $DbgNub(scope)DbgNub_infoCmd context]]
+ } else {
+ set name [DbgNub_uplevelCmd \#$level \
+ [list $DbgNub(scope)namespace current]]
+ }
+
+ # Handle the special case of the [incr Tcl] parser namespace
+ # so classes appear as expected.
+
+ if {$name == "::itcl::parser"} {
+ lappend DbgNub(stack) [list $level class]
+ } else {
+ lappend DbgNub(stack) [list $level namespace eval $name]
+ }
+ continue
+ }
+
+ # Handle [incr Tcl] methods and procedures first. We check to see
+ # if we are in an object context by testing to see where "info"
+ # is coming from. If we're in an object context, we can get all
+ # the info we need from the "info function" command.
+
+ if {$DbgNub(itcl76)} {
+ if {[DbgNub_uplevelCmd \#$level {info which info}] \
+ == "::itcl::builtin::info"} {
+ lappend DbgNub(stack) [concat $level \
+ [DbgNub_uplevelCmd \#$level \
+ [list info function $name -type -name -args]]]
+ continue
+ }
+ } elseif {$DbgNub(namespace)} {
+ if {[DbgNub_uplevelCmd \#$level \
+ [list $DbgNub(scope)namespace origin info]] \
+ == "::itcl::builtin::info"} {
+ lappend DbgNub(stack) [concat $level \
+ [DbgNub_uplevelCmd \#$level \
+ [list info function $name -type -name -args]]]
+ continue
+ }
+ }
+
+ # If we are using namespaces, transform the name to fully qualified
+ # form before trying to get the arglist. Determine whether the
+ # name refers to a proc or a command.
+
+ if {$DbgNub(namespace)} {
+ # Check to see if the name exists in the calling context. If it
+ # isn't present, it must have been deleted while it was on the
+ # stack. This check must be done before calling namespace origin
+ # below or an error will be generated (Bug: 3613).
+
+ set infoLevel \#[expr {$level - 1}]
+ if {[DbgNub_uplevelCmd $infoLevel \
+ [list $DbgNub(scope)info commands $name]] == ""} {
+ lappend DbgNub(stack) [list $level proc $name (deleted)]
+ continue
+ }
+
+ # Now determine the fully qualified name.
+
+ set name [DbgNub_uplevelCmd $infoLevel \
+ [list $DbgNub(scope)namespace origin $name]]
+
+ # Because of Tcl's namespace design, "info procs" does not
+ # work on qualified names. The workaround is to invoke the
+ # "info" command inside the namespace.
+
+ set qual [namespace qualifiers $name]
+ if {$qual == ""} {
+ set qual ::
+ }
+ set tail [namespace tail $name]
+ set isProc [namespace eval $qual \
+ [list DbgNub_infoCmd procs $tail]]
+ } else {
+ # Check to make sure the command still exists.
+
+ if {[DbgNub_uplevelCmd \#[expr {$level - 1}] \
+ [list DbgNub_infoCmd commands $name]] == ""} {
+ lappend DbgNub(stack) [list $level proc $name (deleted)]
+ continue
+ }
+
+ # Check to see if the command is a proc.
+
+ set isProc [DbgNub_infoCmd procs $name]
+ }
+
+ # Attempt to determine the argument list.
+
+ if {$isProc != ""} {
+ set argList [DbgNub_uplevelCmd \#$level \
+ [list DbgNub_infoCmd args $name]]
+ } else {
+ # The command on the stack is not a procedure.
+ # We have to put a special hack in here to work
+ # around a very poor implementation the tk_get*File and
+ # tk_messageBox dialogs on Unix.
+
+ if {[regexp \
+ {^(::)?tk_(messageBox|getOpenFile|getSaveFile)$} \
+ $name dummy1 dummy2 match]} {
+ if {$match == "messageBox"} {
+ set name "tkMessageBox"
+ } else {
+ set name "tkFDialog"
+ }
+ if {$DbgNub(namespace)} {
+ set name "::$name"
+ }
+ set argList "args"
+ } else {
+ set argList ""
+ }
+ }
+ lappend DbgNub(stack) [list $level "proc" $name $argList]
+ }
+ if {$frame != {}} {
+ lappend DbgNub(stack) $frame
+ }
+ return $marker
+}
+
+# DbgNub_PopStack --
+#
+# Pop frames from the stack that were pushed by DbgNub_PushStack.
+#
+# Arguments:
+# marker Marker value returned by DbgNub_PushStack
+#
+# Results:
+# None.
+
+proc DbgNub_PopStack {marker} {
+ global DbgNub
+
+ set DbgNub(stack) [lrange $DbgNub(stack) 0 $marker]
+ return
+}
+
+# DbgNub_CollateStacks --
+#
+# Merge the call stack with the instruction stack. The istack
+# may have more than one frame for any given call stack frame due to
+# virtual frames pushed by commands like "source", but it may also be
+# missing some uninstrumented frames. Because of this, we have to
+# collate the two stacks to recover the complete stack description.
+#
+# Arguments:
+# None.
+#
+# Results:
+# Returns the merged stack.
+
+proc DbgNub_CollateStacks {} {
+ global DbgNub
+
+ set result ""
+
+ # Put the current context and location list onto the stack so
+ # we can deal with the whole mess at once
+
+ lappend DbgNub(contextStack) [list $DbgNub(context) $DbgNub(locations)]
+
+ if {$DbgNub(debug) & 1} {
+ DbgNub_Log "Collate context: $DbgNub(contextStack)\nstack: $DbgNub(stack)"
+ }
+
+ set s [expr {[llength $DbgNub(stack)] - 1}]
+ set i [expr {[llength $DbgNub(contextStack)] - 1}]
+
+ while {$i >= 0} {
+ set iframes {}
+
+ # Look for the next instrumented procedure invocation so we can match
+ # it against the call stack. Generate stack information for each
+ # instrumented instruction location that is in a new block or a new
+ # scope.
+
+ while {$i >= 0} {
+ set frame [lindex $DbgNub(contextStack) $i]
+ incr i -1
+ set locations [lindex $frame 1]
+ set context [lindex $frame 0]
+ set temp {}
+ set block {}
+ for {set l [expr {[llength $locations] - 1}]} {$l >= 0} {incr l -1} {
+ set location [lindex $locations $l]
+ set newBlock [lindex $location 0]
+ if {[string compare $newBlock $block] != 0} {
+ set iframes [linsert $iframes 0 \
+ [linsert $context 1 $location]]
+ set block $newBlock
+ }
+ }
+ # Add a dummy frame if we have an empty context.
+ if {$context != "" && $locations == ""} {
+ set iframes [linsert $iframes 0 [linsert $context 1 {}]]
+ }
+ set type [lindex $context 1]
+ switch $type {
+ configure -
+ debugger_eval -
+ proc -
+ class -
+ global -
+ event -
+ uplevel -
+ method -
+ source -
+ namespace -
+ package {
+ break
+ }
+ }
+ }
+
+ # Find the current instrumented statement on the call stack. Generate
+ # stack information for any uninstrumented frames.
+
+ while {$s >= 0} {
+ set sframe [lindex $DbgNub(stack) $s]
+ incr s -1
+ if {[string compare $context $sframe] == 0} {
+ break
+ } elseif {[string match *(deleted) $sframe] \
+ && ([string compare [lrange $context 0 1] \
+ [lrange $sframe 0 1]] == 0)} {
+ break
+ }
+
+ set result [linsert $result 0 [linsert $sframe 1 {}]]
+ }
+ set result [concat $iframes $result]
+ }
+
+ # Add any uninstrumented frames that appear before the first instrumented
+ # statement.
+
+ while {$s >= 0} {
+ set result [linsert $result 0 [linsert [lindex $DbgNub(stack) $s] 1 {}]]
+ incr s -1
+ }
+ set DbgNub(contextStack) [lreplace $DbgNub(contextStack) end end]
+ if {$DbgNub(debug) & 1} {
+ DbgNub_Log "Collate result: $result"
+ }
+ return $result
+}
+
+# DbgNub_Proc --
+#
+# Define a new instrumented procedure.
+#
+# Arguments:
+# location Location that contains the entire definition.
+# name Procedure name.
+# argList Argument list for procedure.
+# body Instrumented body of procedure.
+#
+# Results:
+# None.
+
+proc DbgNub_Proc {location name argList body} {
+ global DbgNub
+
+ set ns $DbgNub(scope)
+ if {$DbgNub(namespace)} {
+ # Create an empty procedure first so we can determine the correct
+ # absolute name.
+ DbgNub_uplevelCmd 1 [list DbgNub_procCmd $name {} {}]
+ set fullName [DbgNub_uplevelCmd 1 \
+ [list $DbgNub(scope)namespace origin $name]]
+
+ set nameCmd "\[DbgNub_uplevelCmd 1 \[${ns}list ${ns}namespace origin \[${ns}lindex \[${ns}info level 0\] 0\]\]\]"
+ } else {
+ set fullName $name
+
+ set nameCmd "\[lindex \[info level 0\] 0\]"
+ }
+
+ set DbgNub(proc=$fullName) $location
+
+ # Two variables are substituted into the following string. The
+ # fullName variable contains the full name of the procedure at
+ # the time the procedure was created. The body variable contains
+ # the actual "user-specified" code for the procedure.
+ # NOTE: There is some very tricky code at the end relating to unsetting
+ # some local variables. We need to unset local variables that have
+ # traces before the procedure context goes away so things look
+ # rational on the stack. In addition, we have to watch out for upvar
+ # variables because of a bug in Tcl where procedure arguments that are
+ # unset and then later reused as upvar variables will show up in the
+ # locals list. If we did an unset on these, we'd blow away the variable
+ # in the other scope. Instead we just upvar the variable to a dummy
+ # variable that will get cleaned up locally.
+
+ return [DbgNub_uplevelCmd 1 [list DbgNub_procCmd $name $argList \
+ "#DBG INSTRUMENTED PROC TAG
+ ${ns}upvar #0 errorInfo DbgNub_errorInfo errorCode DbgNub_errorCode
+ ${ns}set DbgNub_level \[DbgNub_infoCmd level\]
+ DbgNub_PushProcContext \$DbgNub_level
+ ${ns}set DbgNub_catchCode \[DbgNub_UpdateReturnInfo \[
+ [list DbgNub_catchCmd $body DbgNub_result DbgNub_options]\]\]
+ ${ns}foreach DbgNub_index \[${ns}info locals\] {
+ ${ns}if {\[${ns}trace vinfo \$DbgNub_index\] != \"\"} {
+ ${ns}if {[${ns}catch {${ns}upvar 0 DbgNub_dummy \$DbgNub_index}]} {
+ ${ns}catch {${ns}unset \$DbgNub_index}
+ }
+ }
+ }
+ DbgNub_PopContext
+ ${ns}return -code \$DbgNub_catchCode -errorinfo \$DbgNub_errorInfo -errorcode \$DbgNub_errorCode -options \$DbgNub_options \$DbgNub_result"]]
+}
+
+# DbgNub_PushProcContext --
+#
+# Determine the current procedure context, then push it on the
+# context stack. This routine handles some of the weird cases
+# like procedures that are being invoked by way of an alias.
+# NOTE: much of this code is identical to that in DbgNub_PushStack.
+#
+# Arguments:
+# level The current stack level.
+#
+# Results:
+# None.
+
+proc DbgNub_PushProcContext {level} {
+ global DbgNub
+
+ set name [lindex [DbgNub_infoCmd level $level] 0]
+
+ # If we are using namespaces, transform the name to fully qualified
+ # form before trying to get the arglist. Determine whether the
+ # name refers to a proc or a command.
+
+ if {$DbgNub(namespace)} {
+ set qualName [DbgNub_uplevelCmd \#[expr {$level - 1}] \
+ [list $DbgNub(scope)namespace origin $name]]
+
+ if {$qualName == ""} {
+ DbgNub_PushContext $level "proc" $name {}
+ } else {
+ set name $qualName
+ }
+
+
+ # Because of Tcl's namespace design, "info procs" does not
+ # work on qualified names. The workaround is to invoke the
+ # "info" command inside the namespace.
+
+ set qual [namespace qualifiers $name]
+ if {$qual == ""} {
+ set qual ::
+ }
+ set tail [namespace tail $name]
+ set isProc [namespace eval $qual [list DbgNub_infoCmd procs $tail]]
+ } else {
+ set isProc [DbgNub_infoCmd procs $name]
+ }
+
+ if {$isProc != ""} {
+ set args [DbgNub_uplevelCmd \#$level [list DbgNub_infoCmd args $name]]
+ } else {
+ set args ""
+ }
+ DbgNub_PushContext $level "proc" $name $args
+ return
+}
+
+# DbgNub_WrapItclBody --
+#
+# Define a new instrumented [incr Tcl] function, adding the standard
+# prefix/suffix to the body, if possible. The last argument is
+# expected to be the body of the function.
+#
+# Arguments:
+# args The command and all of its args, the last of which
+# must be the body.
+#
+# Results:
+# None.
+
+proc DbgNub_WrapItclBody {args} {
+ upvar #0 DbgNub(scope) ns
+ set body [lindex $args end]
+ set args [lrange $args 0 [expr {[llength $args] - 2}]]
+ if {[string index $body 0] != "@"} {
+ set body "#DBG INSTRUMENTED PROC TAG
+ ${ns}upvar #0 errorInfo DbgNub_errorInfo errorCode DbgNub_errorCode
+ ${ns}set DbgNub_level \[DbgNub_infoCmd level\]
+ ${ns}eval \[${ns}list DbgNub_PushContext \$DbgNub_level\] \[info function \[${ns}lindex \[info level 0\] 0\] -type -name -args\]
+ ${ns}set DbgNub_catchCode \[DbgNub_UpdateReturnInfo \[
+ [list DbgNub_catchCmd $body DbgNub_result DbgNub_options]\]\]
+ ${ns}foreach DbgNub_index \[${ns}info locals\] {
+ ${ns}if {\[${ns}trace vinfo \$DbgNub_index\] != \"\"} {
+ ${ns}if {[${ns}catch {${ns}upvar 0 DbgNub_dummy \$DbgNub_index}]} {
+ ${ns}catch {${ns}unset \$DbgNub_index}
+ }
+ }
+ }
+ DbgNub_PopContext
+ ${ns}return -code \$DbgNub_catchCode -errorinfo \$DbgNub_errorInfo -errorcode \$DbgNub_errorCode -options \$DbgNub_options \$DbgNub_result"
+ }
+ return [DbgNub_uplevelCmd 1 $args [list $body]]
+}
+
+# DbgNub_WrapItclConfig --
+#
+# Define a new [incr Tcl] config body. These bodies run in a
+# namespace context instead of a procedure context, so we need to
+# call a function instead of putting the code inline.
+#
+# Arguments:
+# args The command that defines the config body, the last argument
+# of which contains the body script.
+#
+# Results:
+# Returns the result of defining the config body.
+
+proc DbgNub_WrapItclConfig {args} {
+ set body [lindex $args end]
+ set args [lrange $args 0 [expr {[llength $args] - 2}]]
+ if {[string index $body 0] != "@"} {
+ set body [list DbgNub_ItclConfig $body]
+ }
+ return [DbgNub_uplevelCmd 1 $args [list $body]]
+}
+
+# DbgNub_ItclConfig --
+#
+# Perform an [incr Tcl] variable configure operation. This is
+# basically just a namespace eval, but we want it to behave like
+# a procedure call in the interface.
+#
+# Arguments:
+# args The original body.
+#
+# Results:
+# Returns the result of evaluating the body.
+
+proc DbgNub_ItclConfig {body} {
+ global errorInfo errorCode DbgNub
+
+ set level [expr {[DbgNub_infoCmd level]-1}]
+ DbgNub_PushContext $level configure
+
+ # Replace the current stack frame with a "configure" frame so we don't
+ # end up with a wierd namespace eval on the stack.
+
+ set marker [DbgNub_PushStack [expr {$level-1}] [list $level configure]]
+ set code [DbgNub_catchCmd \
+ {DbgNub_uplevelCmd 1 $body} result options]
+ DbgNub_PopStack $marker
+
+ # Check to see if we are in the middle of a step-out operation and
+ # we are unwinding from the initial context.
+
+ if {$DbgNub(stepOutLevel) == [llength $DbgNub(contextStack)]} {
+ set DbgNub(stepOutLevel) {}
+ set DbgNub(breakNext) 1
+ }
+ DbgNub_PopContext
+
+ return -code $code -errorinfo $errorInfo -errorcode $errorCode -options $options $result
+}
+
+# DbgNub_Constructor --
+#
+# Define a new instrumented [incr Tcl] constructor.
+#
+# Arguments:
+# cmd "constructor"
+# argList Argument list for method.
+# args The body arguments
+#
+# Results:
+# None.
+
+proc DbgNub_Constructor {cmd argList args} {
+ if {[llength $args] == 2} {
+ # The initializer script isn't a procedure context. It's more
+ # like a namespace eval. In order to get return code handling to
+ # work properly, we need to call a procedure that will push/pop
+ # the context and clean up the return code properly.
+
+ set body1 [list [list DbgNub_ConstructorInit [lindex $args 0]]]
+ } else {
+ # Set the first body to null so it gets thrown away by the concat
+ # in the uplevel command.
+
+ set body1 {}
+ }
+ set body2 [list [lindex $args end]]
+ return [DbgNub_uplevelCmd 1 [list DbgNub_WrapItclBody $cmd $argList] \
+ $body1 $body2]
+}
+
+# DbgNub_ConstructorInit --
+#
+# This function pushes a context for the init block of a constructor.
+#
+# Arguments:
+# body The body of code to evaluate.
+#
+# Results:
+# Returns the result of evaluating the body.
+
+proc DbgNub_ConstructorInit {body} {
+ global errorInfo errorCode
+
+ # Determine the calling context.
+
+ set level [expr {[DbgNub_infoCmd level] - 1}]
+ eval [list DbgNub_PushContext $level] [DbgNub_uplevelCmd 1 \
+ {info function [lindex [info level 0] 0] -type -name -args}]
+
+ set code [DbgNub_catchCmd {DbgNub_uplevelCmd 1 $body} result options]
+
+ DbgNub_PopContext
+ return -code $code -errorinfo $errorInfo -errorcode $errorCode -options $options $result
+}
+
+# DbgNub_Class --
+#
+# Push a new context for a class command. This is really a
+# namespace eval so, it needs to fiddle with the step level.
+#
+# Arguments:
+# cmd Should be "class".
+# name The name of the class being defined.
+# body The body of the class being defined.
+#
+# Results:
+# Returns the result of evaluating the class command.
+
+proc DbgNub_Class {cmd name body} {
+ global errorInfo errorCode DbgNub
+
+ DbgNub_PushContext [DbgNub_infoCmd level] class
+
+ incr DbgNub(stepLevel)
+ if {$DbgNub(stepOutLevel) != {}} {
+ incr DbgNub(stepOutLevel)
+ }
+ set code [DbgNub_catchCmd \
+ {DbgNub_uplevelCmd 1 [list $cmd $name $body]} result options]
+ if {$DbgNub(stepOutLevel) != {}} {
+ incr DbgNub(stepOutLevel) -1
+ }
+ incr DbgNub(stepLevel) -1
+ DbgNub_PopContext
+
+ return -code $code -errorinfo $errorInfo -errorcode $errorCode -options $options $result
+}
+
+# DbgNub_NamespaceEval --
+#
+# Define a new instrumented namespace eval. Pushes a new context
+# and artificially bumps the step level so step over will treat
+# namespace eval like any other control structure.
+#
+# Arguments:
+# args The original namespace command.
+#
+# Results:
+# None.
+
+proc DbgNub_NamespaceEval {args} {
+ global errorInfo errorCode DbgNub
+ set level [DbgNub_infoCmd level]
+
+ if {$DbgNub(itcl76)} {
+ set name [lindex $args 1]
+ set cmd [list $DbgNub(scope)DbgNub_infoCmd context]
+ } else {
+ set name [lindex $args 2]
+ set cmd [list $DbgNub(scope)namespace current]
+ }
+
+ if {![string match ::* $name]} {
+ set name [DbgNub_uplevelCmd 1 $cmd]::$name
+ }
+ regsub -all {::+} $name :: name
+ DbgNub_PushContext $level "namespace eval $name"
+ incr DbgNub(stepLevel)
+ if {$DbgNub(stepOutLevel) != {}} {
+ incr DbgNub(stepOutLevel)
+ }
+ set code [DbgNub_catchCmd {
+ DbgNub_uplevelCmd 1 $args
+ } result options]
+ if {$DbgNub(stepOutLevel) != {}} {
+ incr DbgNub(stepOutLevel) -1
+ }
+ incr DbgNub(stepLevel) -1
+ DbgNub_PopContext
+
+ return -code $code -errorinfo $errorInfo -errorcode $errorCode -options $options $result
+}
+
+proc DbgNub_Apply {args} {
+ global errorInfo errorCode DbgNub
+ set level [DbgNub_infoCmd level]
+
+ set argList [lassign $args x func]
+ set lfunc [llength $func]
+
+ if {$lfunc < 2 || $lfunc > 3} {
+ set msg "can't interpret \"$func\" as a lambda expression"
+ set code [DbgNub_catchCmd {
+ DbgNub_uplevelCmd 1 [list error $msg]
+ } result]
+ return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
+ }
+
+ lassign $func procArgs body ns
+ lassign [concat $ns ::] ns
+
+ set ns [DbgNub_uplevelCmd 1 namespace inscope $ns namespace current]
+ set ns [string trimright $ns :]
+
+ set procName ${ns}::<apply>
+ proc $procName $procArgs $body
+
+ set code [DbgNub_catchCmd {
+ DbgNub_uplevelCmd 1 $procName $argList
+ } result options]
+
+ rename $procName {}
+
+ return -code $code -errorinfo $errorInfo -errorcode $errorCode -options $options $result
+}
+
+# DbgNub_WrapCommands --
+#
+# This command is invoked at the beginning of every instrumented
+# procedure.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc DbgNub_WrapCommands {} {
+ global DbgNub
+
+ foreach cmd $DbgNub(wrappedCommandList) {
+ if {$cmd == "rename"} continue
+
+ rename $cmd DbgNub_${cmd}Cmd
+ rename DbgNub_${cmd}Wrapper $cmd
+ }
+
+ # Need to be a little careful when renaming rename itself...
+ rename rename DbgNub_renameCmd
+ DbgNub_renameCmd DbgNub_renameWrapper rename
+}
+
+# DbgNub_exitWrapper --
+#
+# Called whenever the applpication invokes "exit". Calls the coverage
+# check check command before exitting.
+#
+# Arguments:
+# args Arguments passed to original exit call.
+#
+# Results:
+# Returns the same result that the exit call would have.
+
+if {0} {
+proc DbgNub_exitWrapper {args} {
+ global DbgNub
+
+ set level [expr {[DbgNub_infoCmd level] - 1}]
+ set cmd "DbgNub_Break $level exit $args"
+ eval $cmd
+
+ set exitCmd "DbgNub_exitCmd $args"
+ eval $exitCmd
+}
+}
+
+# DbgNub_catchWrapper --
+#
+# Called whenever the application invokes "catch". Changes the error
+# handling so we don't report errors that are going to be caught.
+#
+# Arguments:
+# args Arguments passed to original catch call.
+#
+# Results:
+# Returns the result of evaluating the catch statement.
+
+proc DbgNub_catchWrapper {args} {
+ global DbgNub errorCode errorInfo
+ set oldCatch $DbgNub(catch)
+ set DbgNub(catch) 0
+ set code [DbgNub_catchCmd {DbgNub_uplevelCmd DbgNub_catchCmd $args} result options]
+ if {$code == 1} {
+ regsub -- DbgNub_catchCmd $errorInfo catch errorInfo
+ }
+ set DbgNub(errorHandled) 0
+ set DbgNub(catch) $oldCatch
+ if {[DbgNub_infoCmd exists DbgNub(returnState)]} {
+ unset DbgNub(returnState)
+ }
+ return -code $code -errorcode $errorCode -errorinfo $errorInfo -options $options $result
+}
+
+# DbgNub_Return --
+#
+# Called whenever the application invokes "return". We need
+# to manage a little extra state when the user uses the -code
+# option because we can't determine the actual code used at the
+# call site. All calls to "return" have a result code of 2 and the
+# real value is stored inside the interpreter where we can't get at
+# it. So we cache the result code in global state and fetch it back
+# at the call site so we can invoke the standard "return" at the
+# proper scope with the proper -code.
+#
+# Arguments:
+# args Arguments passed to original return call.
+#
+# Results:
+# Returns the result of evaluating the return statement.
+
+proc DbgNub_Return {args} {
+ global DbgNub errorCode errorInfo
+
+ # Get the value of the -code option if given. (If it isn't given
+ # then Tcl assumes it is -code OK; we assume the same.
+
+ set realCode "ok"
+ set realErrorCode ""
+ set realErrorInfo ""
+ if {[llength $args] % 2} {
+ array set optArray [lrange $args 0 end-1]
+ } else { array set optArray $args }
+ array set optArray $args
+ foreach {optPattern optName optVar} \
+ {-c* -code realCode -errorc* -errorcode realErrorCode -errori* -errorinfo realErrorInfo -l* -level realLevel} {
+ set optStub [array names optArray $optPattern]
+ if {![string first $optStub $optName]} {
+ set $optVar $optArray($optStub)
+ }
+ }
+ if {[info exists realLevel]} {
+ error "argument -level not supported"
+ }
+
+
+ # Invoke the return command so we can see what the result would have been.
+ # We need to check to see if the call to return failed so we can clean up
+ # the errorInfo. If the call succeeds, we store the real return code so we
+ # can retrieve it later.
+
+ set code [DbgNub_catchCmd {DbgNub_uplevelCmd $DbgNub(scope)return $args} result options]
+ if {$code == 1} {
+ regsub -- DbgNub_Return $errorInfo catch errorInfo
+ } else {
+ set DbgNub(returnState) [list $realCode $realErrorCode $realErrorInfo]
+ }
+ return -code $code -errorcode $errorCode -errorinfo $errorInfo -options $options $result
+}
+
+# DbgNub_UpdateReturnInfo --
+#
+# Restore the errorCode and errorInfo that was cached by DbgNub_Return.
+# Test to see if a step out is in progress and convert it to an
+# interrupt if necessary. This routine is called in the procedure and
+# method header code inserted by the instrumenter as well as the
+# wrapper for the "source" command.
+#
+# Arguments:
+# code The result code of the last command.
+#
+# Results:
+# Returns the new result code, modifies errorCode/errorInfo as
+# needed and creates upvar'd versions of errorCode/errorInfo in
+# the caller's context.
+
+proc DbgNub_UpdateReturnInfo {code} {
+ global errorInfo errorCode DbgNub
+ if {$code == 2 || $code == "return"} {
+ if {[DbgNub_infoCmd exists DbgNub(returnState)]} {
+ set code [lindex $DbgNub(returnState) 0]
+ set errorCode [lindex $DbgNub(returnState) 1]
+ set errorInfo [lindex $DbgNub(returnState) 2]
+ unset DbgNub(returnState)
+ } else {
+ set code 0
+ }
+ }
+ DbgNub_uplevelCmd 1 "
+ $DbgNub(scope)upvar #0 errorInfo DbgNub_errorInfo
+ $DbgNub(scope)upvar #0 errorCode DbgNub_errorCode
+ "
+
+ # Check to see if we are in the middle of a step-out operation and
+ # we are unwinding from the initial context.
+
+ if {$DbgNub(stepOutLevel) == [llength $DbgNub(contextStack)]} {
+ set DbgNub(stepOutLevel) {}
+ set DbgNub(breakNext) 1
+ }
+
+ return $code
+}
+
+# DbgNub_procWrapper --
+#
+# Called whenever the application invokes "proc" on code that has
+# not been instrumented. This allows for dynamic procedures to
+# be instrumented. This feature may be turned off by the user.
+# The DbgNub(dynProc) flag can be used to turn this feature on
+# or off.
+#
+# Arguments:
+# args Arguments passed to original catch call.
+#
+# Results:
+# Returns the result of evaluating the catch statement.
+
+proc DbgNub_procWrapper {args} {
+ global DbgNub errorInfo errorCode
+ set length [llength $args]
+ set unset 0
+
+
+ if {($length == 3) && ($DbgNub(socket) != -1)} {
+
+ # Don't allow redefining of builtin commands that the
+ # debugger relies on.
+
+ set searchName [lindex $args 0]
+ set level [expr {[DbgNub_infoCmd level] - 1}]
+ if {![DbgNub_okToRename $searchName $level]} {
+ return -code 1 \
+ "cannot overwrite \"[lindex $args 0]\" in the debugger"
+ }
+
+ set body [lindex $args end]
+ if {[regexp "\n# DBGNUB START: (\[^\n\]*)\n" $body dummy data]} {
+ # This body is already instrumented, so we should not reinstrument
+ # it, but we do want to define it as an instrumented procedure.
+
+ set icode [linsert $args 0 DbgNub_Proc [lindex $data 0]]
+ } elseif {$DbgNub(dynProc) && !$DbgNub(inExclude) \
+ && ($DbgNub(autoLoad) \
+ || (!$DbgNub(inRequire) && !$DbgNub(inAutoLoad)))} {
+ # This is a dynamic procedure, so we need to instrument it first.
+ # The code we get back starts with a DbgNub_Do which we don't want
+ # to run so we have to strip out the actual proc command.
+
+ set script [linsert $args 0 "proc"]
+ set icode [DbgNub_Instrument "" $script]
+ set loc [lindex $icode 2]
+ set cmd [lindex $icode 3]
+
+ # Now change things so we are calling DbgNub_Proc instead of
+ # proc so this routine gets created like a normal instrumented
+ # procedure.
+
+ set icode [lreplace $cmd 0 0 "DbgNub_Proc" $loc]
+ } else {
+ # This is a dynamic procedure, but we are ignoring them
+ # right now per user setting.
+
+ set icode [linsert $args 0 "DbgNub_procCmd"]
+ set unset 1
+ }
+ set code [DbgNub_catchCmd {DbgNub_uplevelCmd 1 $icode} result]
+ } else {
+ # This isn't a well formed call to proc, or we aren't connected
+ # to the debugger any longer, so let it execute without interference.
+
+ set icode [linsert $args 0 DbgNub_procCmd]
+ set unset 1
+ }
+ set code [DbgNub_catchCmd {DbgNub_uplevelCmd 1 $icode} result]
+
+ if {$unset} {
+ # We need to check if we are replacing an already
+ # instrumented procedure with an uninstrumented body.
+ # If so, we need to clean up some state.
+
+ set name [lindex $args 0]
+ if {$DbgNub(namespace)} {
+ set name [DbgNub_uplevelCmd 1 \
+ [list $DbgNub(scope)namespace which $name]]
+ }
+ if {[DbgNub_infoCmd exists DbgNub(proc=$name)]} {
+ unset DbgNub(proc=$name)
+ }
+ }
+ if {$code == 1} {
+ set result [DbgNub_cleanErrorInfo $result DbgNub_procCmd proc]
+ set DbgNub(cleanWrapper) {DbgNub_procCmd proc}
+ return -code $code -errorcode $errorCode -errorinfo $errorInfo $result
+ }
+ return -code $code -errorcode $errorCode -errorinfo $errorInfo $result
+}
+
+# DbgNub_infoWrapper --
+#
+# Called whenever the applpication invokes "info". Changes the
+# output of some introspection commands to hide the debugger's
+# changes to the environment.
+#
+# Arguments:
+# args Arguments passed to original info call.
+#
+# Results:
+# Returns the result of evaluating the info statement.
+
+proc DbgNub_infoWrapper {args} {
+ global DubNub errorCode errorInfo
+ set code [DbgNub_catchCmd {DbgNub_uplevelCmd DbgNub_infoCmd $args} result]
+ if {$code == 1} {
+ set result [DbgNub_cleanErrorInfo $result DbgNub_infoCmd info]
+ set DbgNub(cleanWrapper) {DbgNub_infoCmd info}
+ return -code $code -errorcode $errorCode -errorinfo $errorInfo $result
+ }
+ switch -glob -- [lindex $args 0] {
+ comm* -
+ pr* {
+ set newResult ""
+ foreach x $result {
+ if {![regexp DbgNub_* $x]} {
+ # Strip out the commands we wrapped.
+ global DbgNub
+
+ if {[lsearch $DbgNub(wrappedCommandList) $x] != -1} {
+ if {[string match p* [lindex $args 0]]} {
+ continue
+ }
+ }
+ lappend newResult $x
+ }
+ }
+ set result $newResult
+ }
+ loc* -
+ v* -
+ g* {
+ # We string out the DbgNub variable and any variable that
+ # begins with DbgNub_
+
+ set i [lsearch -exact $result DbgNub]
+ if {$i != -1} {
+ set result [lreplace $result $i $i]
+ }
+ set newResult ""
+ foreach x $result {
+ if {[regexp DbgNub_* $x]} {
+ continue
+ }
+ lappend newResult $x
+ }
+ set result $newResult
+ }
+ b* {
+ if {[string compare "#DBG INSTRUMENTED PROC TAG" $result] == -1} {
+ global DbgNub
+
+ set name [lindex $args 1]
+ if {$DbgNub(namespace)} {
+ set name [DbgNub_uplevelCmd 1 \
+ [list $DbgNub(scope)namespace origin $name]]
+ }
+ if {! [DbgNub_infoCmd exists DbgNub(proc=$name)]} {
+ error "debugger in inconsistant state"
+ }
+ DbgNub_SendMessage PROCBODY $DbgNub(proc=$name)
+ DbgNub_ProcessMessages 1
+ return $DbgNub(body)
+ }
+ }
+ sc* {
+ global DbgNub
+ return [lindex $DbgNub(script) end]
+ }
+ }
+ return -code $code -errorcode $errorCode -errorinfo $errorInfo $result
+}
+
+# DbgNub_sourceWrapper --
+#
+# Called whenever the application tries to source a file.
+# Loads the file and passes the contents to the debugger to
+# be instrumented.
+#
+# Arguments:
+# file File name to source.
+#
+# Results:
+# Returns the result of evaluating the instrumented code.
+
+proc DbgNub_sourceWrapper {args} {
+ global DbgNub errorCode errorInfo
+
+ if {[llength $args] == 1} {
+ set file [lindex $args 0]
+ } else {
+ # Let the real source command generate the error for bad args.
+
+ set code [DbgNub_catchCmd {DbgNub_uplevelCmd DbgNub_sourceCmd $args} \
+ result]
+ set errorInfo ""
+ regsub -- "DbgNub_sourceCmd" $result "source" result
+ return -code $code -errorcode $errorCode $result
+ }
+
+ # Short circuit the procedure if we aren't connected to the debugger.
+
+ if {$DbgNub(socket) == -1} {
+ set code [DbgNub_catchCmd {
+ DbgNub_uplevelCmd [list DbgNub_sourceCmd $file]
+ } result options]
+ return -code $code -errorcode $errorCode -errorinfo $errorInfo \
+ -options $options $result
+ }
+
+ # If the users preferences indicate that autoloaded scripts
+ # are not to be instrumented, then check to see if this file
+ # is being autoloaded. The test is to look up the stack, if
+ # the "auto_load" or "auto_import" procs are on the stack, then we are
+ # autoloading.
+
+ if {!$DbgNub(autoLoad)} {
+ set DbgNub(inAutoLoad) 0
+ foreach stack $DbgNub(stack) {
+ if {([lindex $stack 1] == "proc") \
+ && [regexp {^(::)?auto_(load|import)$} \
+ [lindex $stack 2]]} {
+ set DbgNub(inAutoLoad) 1
+ break
+ }
+ }
+ }
+
+ # Clear the inExclude flag since we are about to source a new file and
+ # any previous exclude flag doesn't apply until we are done.
+
+ set oldExclude $DbgNub(inExclude)
+ set DbgNub(inExclude) 0
+
+ if {!$DbgNub(autoLoad) && ($DbgNub(inAutoLoad) || $DbgNub(inRequire))} {
+ set dontInstrument 1
+ } else {
+ # Check to see if this file matches any of the included file
+ # patterns. If not set the dontInstrument flag to true,
+ # so the file is not instrumented. Otherwise, check to see if
+ # it matches one of the excluded file patterns.
+
+ set dontInstrument 1
+ foreach pattern $DbgNub(includeFiles) {
+ if {[string match $pattern $file]} {
+ set dontInstrument 0
+ break
+ }
+ }
+ if {$dontInstrument} {
+ set DbgNub(inExclude) 1
+ } else {
+ # Check to see if this file matches any of the excluded file
+ # patterns. If it does, set the dontInstrument flag to true,
+ # so the file is not instrumented.
+
+ foreach pattern $DbgNub(excludeFiles) {
+ if {[string match $pattern $file]} {
+ set dontInstrument 1
+ set DbgNub(inExclude) 1
+ break
+ }
+ }
+ }
+ }
+
+ # If the "dontInstrument" flag is true, just source the file
+ # normally, taking care to propagate the error result.
+ # NOTE: this will not work on the Macintosh because of its additional
+ # arguments.
+
+ if {$dontInstrument} {
+ # Set the global value DbgNub(dynProc) to false so procs
+ # defined in the uninstrumented file will not become
+ # instrumented even if the dynProcs flag was true.
+ # Restore the value to the value when done with the
+ # read-only copy of the original dynProc variable.
+
+ lappend DbgNub(script) $file
+
+ set code [DbgNub_catchCmd {
+ DbgNub_uplevelCmd [list DbgNub_sourceCmd $file]
+ } result options]
+
+ set DbgNub(script) [lreplace $DbgNub(script) end end]
+ set DbgNub(inExclude) $oldExclude
+
+ return -code $code -errorcode $errorCode -errorinfo $errorInfo \
+ -options $options $result
+ }
+
+ lappend DbgNub(script) $file
+
+ # Pass the contents of the file to the debugger for
+ # instrumentation.
+
+ set result [catch {set f [open $file r]} msg]
+ if {$result != 0} {
+ # We failed to open the file, so let source take care of generating
+ # the error.
+
+ set DbgNub(script) [lreplace $DbgNub(script) end end]
+ set DbgNub(inExclude) $oldExclude
+
+ set code [DbgNub_catchCmd {
+ DbgNub_uplevelCmd DbgNub_sourceCmd $args
+ } result]
+ set errorInfo ""
+ regsub -- "DbgNub_sourceCmd" $result "source" result
+ return -code $code -errorcode $errorCode $result
+ }
+ set source [read $f]
+ close $f
+
+ # We now need to calculate the absolute path so the
+ # engine will be able to point to this file. We then pass
+ # the script to the engine to be processed.
+
+ set oldwd [pwd]
+ cd [file dir $file]
+ set absfile [file join [pwd] [file tail $file]]
+ cd $oldwd
+
+ set icode [DbgNub_Instrument $absfile $source]
+
+ # If the instrumentation failed, we just source the original file
+
+ if {$icode == ""} {
+ set icode $source
+ }
+
+ # Evaluate the instrumented code, propagating
+ # errors that might occur during the eval.
+
+ set level [expr {[DbgNub_infoCmd level] - 1}]
+ DbgNub_PushContext $level "source" $file
+ set marker [DbgNub_PushStack $level [list $level "source" $file]]
+ set code [DbgNub_UpdateReturnInfo [DbgNub_catchCmd {
+ DbgNub_uplevelCmd 1 $icode
+ } result options]]
+ DbgNub_PopStack $marker
+ DbgNub_PopContext
+
+ set DbgNub(script) [lreplace $DbgNub(script) end end]
+ set DbgNub(inExclude) $oldExclude
+
+ if {($code == 1) || ($code == "error")} {
+ set result [DbgNub_cleanErrorInfo $result DbgNub_sourceCmd info]
+ set DbgNub(cleanWrapper) {DbgNub_sourceCmd source}
+ set errorInfo "$result$errorInfo"
+ set errorCode NONE
+ error $result $errorInfo $errorCode
+ }
+ return -code $code -errorcode $errorCode -errorinfo $errorInfo -options $options $result
+}
+
+# DbgNub_vwaitWrapper --
+#
+# Called whenever the program enters the event loop. Records a
+# discontinuity in the Tcl stack.
+#
+# Arguments:
+# args Arguments passed to original vwait call.
+#
+# Results:
+# Returns the result of the vwait statement.
+
+proc DbgNub_vwaitWrapper {args} {
+ global DbgNub errorCode errorInfo
+ DbgNub_PushContext 0 event
+ set marker [DbgNub_PushStack [expr {[DbgNub_infoCmd level] - 1}] "0 event"]
+ set oldCatch $DbgNub(catch)
+ set DbgNub(catch) 1
+ set oldCount $DbgNub(nestCount)
+ set DbgNub(nestCount) 0
+ set code [DbgNub_catchCmd {
+ DbgNub_uplevelCmd DbgNub_vwaitCmd $args
+ } result]
+ set DbgNub(catch) $oldCatch
+ set DbgNub(nestCount) $oldCount
+ DbgNub_PopStack $marker
+ DbgNub_PopContext
+ if {$code == 1} {
+ set result [DbgNub_cleanErrorInfo $result DbgNub_vwaitCmd vwait]
+ set DbgNub(cleanWrapper) {DbgNub_vwaitCmd vwait}
+ }
+ return -code $code -errorcode $errorCode -errorinfo $errorInfo $result
+}
+
+# DbgNub_updateWrapper --
+#
+# Called whenever the program enters the event loop. Records a
+# discontinuity in the Tcl stack.
+#
+# Arguments:
+# args Arguments passed to original update call.
+#
+# Results:
+# Returns the result of the update statement.
+
+proc DbgNub_updateWrapper {args} {
+ global DbgNub errorCode errorInfo
+ DbgNub_PushContext 0 event
+ set marker [DbgNub_PushStack [expr {[DbgNub_infoCmd level] - 1}] "0 event"]
+ set oldCatch $DbgNub(catch)
+ set DbgNub(catch) 1
+ set oldCount $DbgNub(nestCount)
+ set DbgNub(nestCount) 0
+ set code [DbgNub_catchCmd {
+ DbgNub_uplevelCmd DbgNub_updateCmd $args
+ } result]
+ set DbgNub(catch) $oldCatch
+ set DbgNub(nestCount) $oldCount
+ DbgNub_PopStack $marker
+ DbgNub_PopContext
+ if {$code == 1} {
+ set result [DbgNub_cleanErrorInfo $result DbgNub_updateCmd update]
+ set DbgNub(cleanWrapper) {DbgNub_updateCmd update}
+ }
+ return -code $code -errorcode $errorCode -errorinfo $errorInfo $result
+}
+
+# DbgNub_uplevelWrapper --
+#
+# Called whenever the program calls uplevel. Records a
+# discontinuity in the Tcl stack.
+#
+# Arguments:
+# args Arguments passed to original uplevel call.
+#
+# Results:
+# Returns the result of the uplevel statement.
+
+proc DbgNub_uplevelWrapper {args} {
+ global errorCode errorInfo
+ set level [lindex $args 0]
+ if {[string index $level 0] == "#"} {
+ set level [string range $level 1 end]
+ set local 0
+ } else {
+ set local 1
+ }
+ if {[DbgNub_catchCmd {incr level 0}]} {
+ set level [expr {[DbgNub_infoCmd level] - 2}]
+ } elseif {$local} {
+ set level [expr {[DbgNub_infoCmd level] - 1 - $level}]
+ }
+ DbgNub_PushContext $level uplevel
+ set marker [DbgNub_PushStack \
+ [expr {[DbgNub_infoCmd level] - 1}] [list $level uplevel]]
+ set code [DbgNub_catchCmd {
+ DbgNub_uplevelCmd DbgNub_uplevelCmd $args
+ } result options]
+ DbgNub_PopStack $marker
+ DbgNub_PopContext
+ if {$code == 1} {
+ set result [DbgNub_cleanErrorInfo $result DbgNub_uplevelCmd uplevel]
+ set DbgNub(cleanWrapper) {DbgNub_uplevelCmd uplevel}
+ }
+ return -code $code -errorcode $errorCode -errorinfo $errorInfo -options $options $result
+}
+
+# DbgNub_packageWrapper --
+#
+# Called whenever the program calls package. Records a
+# discontinuity in the Tcl stack.
+#
+# Arguments:
+# args Arguments passed to original package call.
+#
+# Results:
+# Returns the result of the package statement.
+
+proc DbgNub_packageWrapper {args} {
+ global errorCode errorInfo DbgNub
+
+ set level [expr {[DbgNub_infoCmd level] - 1}]
+ set cmd [lindex $args 0]
+
+ set oldRequire $DbgNub(inRequire)
+ set DbgNub(inRequire) 1
+
+ DbgNub_PushContext 0 package $cmd
+ set marker [DbgNub_PushStack $level [list 0 "package" $cmd]]
+ set code [DbgNub_catchCmd {
+ DbgNub_uplevelCmd DbgNub_packageCmd $args
+ } result]
+ DbgNub_PopStack $marker
+ DbgNub_PopContext
+
+ set DbgNub(inRequire) $oldRequire
+
+ if {$code == 1} {
+ set result [DbgNub_cleanErrorInfo $result DbgNub_packageCmd package]
+ set DbgNub(cleanWrapper) {DbgNub_packageCmd package}
+ }
+
+ return -code $code -errorcode $errorCode -errorinfo $errorInfo $result
+}
+
+# DbgNub_renameWrapper --
+#
+# A replacement for the standard "rename" command. We need to
+# do a little extra work when renaming instrumented procs.
+#
+# Arguments:
+# args Arguments passed to original rename call.
+#
+# Results:
+# Returns the result of the rename statement.
+
+proc DbgNub_renameWrapper {args} {
+ global DbgNub errorCode errorInfo
+
+ # Check to see if the name we are about to rename is in a namespace.
+ # We need to get the full name for this command before and after
+ # it is renamed.
+
+ if {[llength $args] > 0} {
+ set level [expr {[DbgNub_infoCmd level] - 1}]
+
+ set name [lindex $args 0]
+ if {$DbgNub(namespace)} {
+ set name [DbgNub_uplevelCmd 1 \
+ [list $DbgNub(scope)namespace origin $name]]
+
+ # Check to see if the command we are about to rename is imported
+ # from a namespace. If so we need to short circuit out here
+ # because imported procs will choke on the code below.
+
+ if {$name != [DbgNub_uplevelCmd 1 \
+ [list $DbgNub(scope)namespace which [lindex $args 0]]]} {
+ set $name [lindex $args 0]
+ set code [DbgNub_catchCmd {
+ DbgNub_uplevelCmd DbgNub_renameCmd $args
+ } result]
+ if {$code == 1} {
+ set result [DbgNub_cleanErrorInfo $result \
+ DbgNub_renameCmd rename]
+ set DbgNub(cleanWrapper) {DbgNub_renameCmd rename}
+ }
+ return -code $code -errorcode $errorCode -errorinfo \
+ $errorInfo $result
+ }
+ }
+
+ # Check to see if the name we are about to rename is in the
+ # list of commands that cannot be renamed. If it is generate
+ # an error stating that renaming the command will crash the
+ # debugger.
+
+ if {![DbgNub_okToRename $name $level]} {
+ return -code 1 \
+ "cannot rename \"[lindex $args 0]\" in the debugger"
+ }
+ }
+
+ set code [DbgNub_catchCmd {
+ DbgNub_uplevelCmd DbgNub_renameCmd $args
+ } result]
+ if {$code == 1} {
+ set result [DbgNub_cleanErrorInfo $result DbgNub_renameCmd rename]
+ set DbgNub(cleanWrapper) {DbgNub_renameCmd rename}
+ return -code $code -errorcode $errorCode -errorinfo $errorInfo $result
+ }
+
+ # Check to see if the command we just renamed was instrumented.
+ # If so, we need to update our info and fix the body of the
+ # procedure to add the correct info to the context stack.
+
+ set newName [lindex $args 1]
+ if {[info exists DbgNub(proc=$name)]} {
+ if {$newName == ""} {
+ unset DbgNub(proc=$name)
+ } else {
+ if {$DbgNub(namespace)} {
+ if {$DbgNub(namespace)} {
+ set newName [DbgNub_uplevelCmd 1 \
+ [list $DbgNub(scope)namespace origin $newName]]
+ }
+ }
+ set DbgNub(proc=$newName) $DbgNub(proc=$name)
+ unset DbgNub(proc=$name)
+ }
+ }
+
+ # Finally check to see if the command just renamed was one of the
+ # builting commands that the nub wrapped.
+
+ set name [string trim $name :]
+ set i [lsearch $DbgNub(wrappedCommandList) $name]
+ if {$i != -1} {
+ set DbgNub(wrappedCommandList) [lreplace $DbgNub(wrappedCommandList) \
+ $i $i [string trim $newName :]]
+ }
+
+ return -code $code -errorcode $errorCode -errorinfo $errorInfo $result
+}
+
+# DbgNub_CheckLineBreakpoints --
+#
+# Check the current location against the list of breakpoint
+# locations to determine if we need to stop at the current
+# statement.
+#
+# Arguments:
+# location Current location.
+# level Stack level of current statement.
+#
+# Results:
+# Returns 1 if we should break at this statement.
+
+proc DbgNub_CheckLineBreakpoints {location level} {
+ global DbgNub
+
+ set block [lindex $location 0]
+ set line [lindex $location 1]
+
+ if {[DbgNub_infoCmd exists DbgNub($block:$line)]} {
+ foreach test $DbgNub($block:$line) {
+ if {($test == "") || ([DbgNub_uplevelCmd #$level $test] == "1")} {
+ return 1
+ }
+ }
+ }
+ return 0
+}
+
+# DbgNub_GetVarTrace --
+#
+# Retrieve the trace handle for the given variable if one exists.
+#
+# Arguments:
+# level The scope at which the variable is defined.
+# name The name of the variable.
+#
+# Results:
+# Returns the trace handle or {} if none is defined.
+
+proc DbgNub_GetVarTrace {level name} {
+ global DbgNub
+
+ if {! [DbgNub_uplevelCmd #$level [list DbgNub_infoCmd exists $name]]} {
+ return ""
+ }
+
+ upvar #$level $name var
+ foreach trace [trace vinfo var] {
+ set command [lindex $trace 1]
+ if {[string compare [lindex $command 0] "DbgNub_TraceVar"] == 0} {
+ set handle [lindex $command 1]
+ if {[DbgNub_infoCmd exists DbgNub(var:$handle)]} {
+ return $handle
+ }
+ }
+ }
+
+ return ""
+}
+
+# DbgNub_AddVarTrace --
+#
+# Add a new debugger trace for the given variable.
+#
+# Arguments:
+# level The scope at which the variable is defined.
+# name The name of the variable.
+# handle The variable handle.
+#
+# Results:
+# None. Creates a trace and sets up the state info for the variable.
+
+proc DbgNub_AddVarTrace {level name} {
+ global DbgNub
+ upvar #$level $name var
+
+ # Check to see if a trace already exists and bump the reference count.
+
+ set handle [DbgNub_GetVarTrace $level $name]
+ if {$handle != ""} {
+ incr DbgNub(varRefs:$handle)
+ return $handle
+ }
+
+ if {[array exists var]} {
+ set type array
+ } else {
+ set type scalar
+ }
+
+ # Find an unallocated trace handle
+
+ set handle [incr DbgNub(varHandle)]
+ while {[DbgNub_infoCmd exists DbgNub(var:$handle)]} {
+ set handle [incr DbgNub(varHandle)]
+ }
+
+ # Initialize the trace
+
+ set DbgNub(var:$handle) {}
+ set DbgNub(varRefs:$handle) 1
+ trace variable var wu "DbgNub_TraceVar $handle $type"
+ return $handle
+}
+
+# DbgNub_RemoveVarTrace --
+#
+# Marks a variable trace as being deleted so it will be cleaned up
+# the next time the variable trace fires.
+#
+# Arguments:
+# handle The debugger trace handle for this variable.
+#
+# Results:
+# None.
+
+proc DbgNub_RemoveVarTrace {handle} {
+ global DbgNub
+ if {[incr DbgNub(varRefs:$handle) -1] == 0} {
+ unset DbgNub(var:$handle)
+ unset DbgNub(varRefs:$handle)
+ }
+ return
+}
+
+# DbgNub_AddBreakpoint --
+#
+# Add a breakpoint.
+#
+# Arguments:
+# type One of "line" or "var".
+# where If the type is "line", then where contains a location.
+# If the type is "var", then where contains a trace
+# handle for the variable break on.
+# test The test to use to determine whether a breakpoint
+# should be generated when the trace triggers. This
+# script is evaluated at the scope where the trace
+# triggered. If the script returns 1, a break is
+# generated.
+#
+# Results:
+# None.
+
+proc DbgNub_AddBreakpoint {type where {test {}}} {
+ global DbgNub
+ switch $type {
+ line {
+ # Ensure that we are looking for line breakpoints.
+
+ if {[lsearch -exact $DbgNub(breakPreChecks) \
+ DbgNub_CheckLineBreakpoints] == -1} {
+ lappend DbgNub(breakPreChecks) DbgNub_CheckLineBreakpoints
+ }
+ set block [lindex $where 0]
+ set line [lindex $where 1]
+
+
+ lappend DbgNub($block:$line) $test
+ incr DbgNub(numBreaks)
+ }
+ var {
+ # Add to the list of tests for the trace.
+
+ if {[DbgNub_infoCmd exists DbgNub(var:$where)]} {
+ lappend DbgNub(var:$where) $test
+ }
+ }
+ }
+ return
+}
+
+# DbgNub_RemoveBreakpoint --
+#
+# Remove the specified breakpoint.
+#
+# Arguments:
+# type One of "line" or "var".
+# where If the type is "line", then where contains a location.
+# If the type is "var", then where contains a trace
+# handle for the variable break on.
+# test The test to remove.
+#
+# Results:
+# None.
+
+proc DbgNub_RemoveBreakpoint {type where test} {
+ global DbgNub
+
+ switch $type {
+ line {
+ set block [lindex $where 0]
+ set line [lindex $where 1]
+
+ # Remove the breakpoint.
+
+ if {[DbgNub_infoCmd exists DbgNub($block:$line)]} {
+ set index [lsearch -exact $DbgNub($block:$line) $test]
+ set tests [lreplace $DbgNub($block:$line) $index $index]
+ if {$tests == ""} {
+ unset DbgNub($block:$line)
+ } else {
+ set DbgNub($block:$line) $tests
+ }
+ incr DbgNub(numBreaks) -1
+ }
+
+ # If this was the last breakpoint, remove the line breakpoint
+ # check routine from the check list.
+
+ if {$DbgNub(numBreaks) == 0} {
+ set index [lsearch -exact $DbgNub(breakPreChecks) \
+ DbgNub_CheckLineBreakpoints]
+ set DbgNub(breakPreChecks) [lreplace $DbgNub(breakPreChecks) \
+ $index $index]
+ }
+ }
+ var {
+ # Remove the test from the trace.
+
+ if {[DbgNub_infoCmd exists DbgNub(var:$where)]} {
+ set index [lsearch -exact $DbgNub(var:$where) $test]
+ set DbgNub(var:$where) [lreplace $DbgNub(var:$where) \
+ $index $index]
+ }
+ }
+ }
+ return
+}
+
+# DbgNub_TraceVar --
+#
+# This procedure is invoked when a traced variable is written to or
+# unset. It reports the event to the debugger and waits to see if it
+# should generate a breakpoint event.
+#
+# Arguments:
+# handle The debugger trace handle for this variable.
+# type The type of variable trace, either "array" or "scalar".
+# name1 The first part of the variable name.
+# name2 The second part of the variable name.
+# op The variable operation being performed.
+#
+# Results:
+# None.
+
+proc DbgNub_TraceVar {handle type name1 name2 op} {
+ global DbgNub
+
+
+ if {$DbgNub(socket) == -1} {
+ return
+ }
+
+ set level [expr {[DbgNub_infoCmd level] - 1}]
+
+ # Process any queued messages without blocking. This ensures that
+ # we have seen any changes in the tracing state before we process
+ # this event.
+
+ DbgNub_ProcessMessages 0
+
+ # Compute the complete name and the correct operation to report
+
+ if {$type == "array"} {
+ if {$name2 != "" && $op == "u"} {
+ set op "w"
+ }
+ set name $name1
+ } elseif {$name2 == ""} {
+ set name $name1
+ } else {
+ set name ${name1}($name2)
+ }
+
+ # Clean up the trace state if the handle is dead.
+
+ if {! [DbgNub_infoCmd exists DbgNub(var:$handle)]} {
+ trace vdelete $name wu "DbgNub_TraceVar $handle $type"
+ return
+ }
+
+ # If the variable is being written, check to see if we should generate a
+ # breakpoint. Note that we execute all of the tests in case they have side
+ # effects that are desired.
+
+ if {$op != "u"} {
+ set varBreak 0
+ foreach test $DbgNub(var:$handle) {
+ if {($test == "")} {
+ set varBreak 1
+ } elseif {([DbgNub_catchCmd {DbgNub_uplevelCmd #$level $test} result] == 0) \
+ && $result} {
+ set varBreak 1
+ }
+ }
+ if {$varBreak} {
+ DbgNub_Break $level varbreak $name $op
+ }
+ } else {
+ unset DbgNub(var:$handle)
+ unset DbgNub(varRefs:$handle)
+ DbgNub_SendMessage UNSET $handle
+ }
+}
+
+# DbgNub_Evaluate --
+#
+# Evaluate a user script at the specified level. The script is
+# treated like an uninstrumented frame on the stack.
+#
+# Arguments:
+# id This id should be returned with the result.
+# level The scope at which the script should be evaluated.
+# script The script that should be evaluated.
+#
+# Results:
+# None.
+
+proc DbgNub_Evaluate {id level script} {
+ global DbgNub errorInfo errorCode
+
+ # Save the debugger state so we can restore it after the evaluate
+ # completes. Reset the error handling flags so we don't notify the
+ # debugger of errors generated by the script until we complete the
+ # evaluation.
+
+ set saveState {}
+ foreach element {state catch errorHandled nestCount breakNext} {
+ lappend saveState $element $DbgNub($element)
+ }
+ array set DbgNub {catch 0 errorHandled 0 nestCount 0 breakNext 0}
+
+ DbgNub_PushContext $level "user eval"
+
+ set code [DbgNub_catchCmd {DbgNub_uplevelCmd #$level $script} result]
+ if {$code == 1} {
+ # Clean up the errorInfo stack to remove our tracks.
+ DbgNub_cleanErrorInfo
+ DbgNub_cleanWrappers
+ }
+
+ # Restore the debugger state.
+
+ DbgNub_PopContext
+ array set DbgNub $saveState
+
+ DbgNub_SendMessage BREAK [DbgNub_CollateStacks] [DbgNub_GetCoverage] \
+ result [list $id $code $result $errorInfo $errorCode]
+}
+
+# DbgNub_BeginCoverage --
+#
+# Set global coverage boolean to true.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc DbgNub_BeginCoverage {} {
+ global DbgNub
+
+ set DbgNub(cover) 1
+ foreach index [array names DbgNub cover:*] {
+ unset DbgNub($index)
+ }
+ return
+}
+
+# DbgNub_EndCoverage --
+#
+# Set global coverage boolean to false, and clear all memory of
+# covered locations.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc DbgNub_EndCoverage {} {
+ global DbgNub
+
+ set DbgNub(cover) 0
+ foreach index [array names DbgNub cover:*] {
+ unset DbgNub($index)
+ }
+ return
+}
+
+# DbgNub_GetCoverage --
+#
+# Find the list of ranges that have been covered
+# since the last time this command was called; then remove
+# all memory of covered locations.
+#
+# Arguments:
+# None.
+#
+# Results:
+# Returns the list of ranges that have been covered
+# since the last time this command was called.
+
+proc DbgNub_GetCoverage {} {
+ global DbgNub
+
+ if {$DbgNub(cover)} {
+ set coverage [array get DbgNub cover:*]
+
+ foreach index [array names DbgNub cover:*] {
+ unset DbgNub($index)
+ }
+ return $coverage
+ }
+ return {}
+}
+
+# DbgNub_GetProcDef --
+#
+# Reconstruct a procedure definition.
+#
+# Arguments:
+# name The name of the procedure to reconstruct.
+#
+# Results:
+# Returns a script that can be used to recreate a procedure.
+
+proc DbgNub_GetProcDef {name} {
+ global DbgNub DbgNubTemp
+ set body [DbgNub_uplevelCmd #0 [list DbgNub_infoCmd body $name]]
+ set args [DbgNub_uplevelCmd #0 [list DbgNub_infoCmd args $name]]
+ set argList {}
+ foreach arg $args {
+ if {[DbgNub_uplevelCmd #0 [list \
+ DbgNub_infoCmd default $name $arg DbgNubTemp]]} {
+ lappend argList [list $arg $DbgNubTemp]
+ } else {
+ lappend argList $arg
+ }
+ }
+ return [list proc $name $argList $body]
+}
+
+# DbgNub_Interrupt --
+#
+# Interrupt the currently running application by stopping at
+# the next instrumented statement.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc DbgNub_Interrupt {} {
+ global DbgNub
+ set DbgNub(breakNext) 1
+ return
+}
+
+# DbgNub_IgnoreError --
+#
+# Ignore the current error.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc DbgNub_IgnoreError {} {
+ global DbgNub
+ set DbgNub(ignoreError) 1
+ return
+}
+
+# DbgNub_cleanErrorInfo --
+#
+# This attepts to remove our tracks from wrapper functions for
+# the Tcl commands like info, source, rename, etc.
+#
+# Arguments:
+# result The dirty result.
+# wrapCmd The wraped command we want to replace.
+# actualCmd The actualy command errorInfo & result should have.
+#
+# Results:
+# Returns the cleaned result string.
+
+proc DbgNub_cleanErrorInfo {{result {}} {wrapCmd {}} {actualCmd {}}} {
+ global errorInfo
+ if {$wrapCmd != {}} {
+ if {[string match "wrong # args:*" $result]} {
+ regsub -- $wrapCmd $result $actualCmd result
+ regsub -- $wrapCmd $errorInfo $actualCmd errorInfo
+ }
+ }
+
+ # Hide shadow procedure invocations. This is pretty complicated because
+ # Tcl doesn't support non-greedy regular expressions.
+
+ while {[regexp -indices "\n invoked from within\n\"\[^\n\]*__DbgNub__" \
+ $errorInfo range]} {
+ set newInfo [string range $errorInfo 0 [lindex $range 0]]
+ set substring [string range $errorInfo \
+ [expr {[lindex $range 0] + 1}] end]
+ regexp -indices "\n\"DbgNub_catchCmd\[^\n\]*\n" $substring range
+ append newInfo [string range $substring [expr {[lindex $range 1]+1}] end]
+ set errorInfo $newInfo
+ }
+ while {[regexp -indices "\n invoked from within\n\"\DbgNub_Do" \
+ $errorInfo range]} {
+ set newInfo [string range $errorInfo 0 [lindex $range 0]]
+ set substring [string range $errorInfo [lindex $range 1] end]
+ regexp -indices " invoked from within\n" $substring range
+ append newInfo [string range $substring [lindex $range 0] end]
+ set errorInfo $newInfo
+ }
+
+ set pat "\n \\(\"uplevel\" body line \[^\n\]*\\)\n invoked from within\n\"DbgNub_uplevelCmd 1 \[^\n\]*\""
+ regsub -all -- $pat $errorInfo {} errorInfo
+
+ return $result
+}
+
+# DbgNub_cleanWrappers --
+#
+# This procedure will clean up some our tracks in the errorInfo
+# variable by hiding the wrapping of certain core commands. Each
+# wrapper will note that it needs to be cleaned up by setting
+# variableDbgNub(cleanWrappers). The DbgNub_Do command is what will
+# actually call this procedure.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None. The global errorInfo variable may be modified.
+
+proc DbgNub_cleanWrappers {} {
+ global DbgNub errorInfo
+
+ if {[DbgNub_infoCmd exists DbgNub(cleanWrapper)]} {
+ set wrap [lindex $DbgNub(cleanWrapper) 0]
+ set actu [lindex $DbgNub(cleanWrapper) 1]
+ set dbgMsg "\"$wrap.*"
+ append dbgMsg \n { invoked from within}
+ append dbgMsg \n "\"$actu"
+ regsub -- $dbgMsg $errorInfo "\"$actu" errorInfo
+ unset DbgNub(cleanWrapper)
+ }
+}
+
+# DbgNub_okToRename --
+#
+# This procedure checks that it is safe to rename (or redefine) a
+# given command.
+#
+# Arguments:
+# name The command name to check.
+# level Stack level of current statement.
+#
+# Results:
+# Returns 1 if it is safe to modify the given command name in the
+# current context, else returns 0.
+#
+# Side effects:
+# None.
+
+proc DbgNub_okToRename {name level} {
+ global DbgNub
+
+ if {$DbgNub(namespace)} {
+ if {![string match ::* $name]} {
+ set name [DbgNub_uplevelCmd \#$level \
+ [list $DbgNub(scope)namespace current]]::$name
+ }
+ if {[string length [namespace qualifiers $name]] == 0} {
+ set name [namespace tail $name]
+ } else {
+ set name {}
+ }
+ }
+ return [expr [lsearch $DbgNub(excludeRename) $name] < 0]
+}
+
+
+##############################################################################
+# Initialize the nub library. Once this completes successfully, we can
+# safely replace the debugger_eval and debugger_init routines.
+
+DbgNub_Startup
+
+# debugger_init --
+#
+# This is a replacement for the public debugger_init routine
+# that does nothing. This version of the function is installed
+# once the debugger is successfully initialized.
+#
+# Arguments:
+# args Ignored.
+#
+# Results:
+# Returns 1.
+
+DbgNub_procCmd debugger_init {args} {
+ return [debugger_attached]
+}
+
+# debugger_eval --
+#
+# Instrument and evaluate the specified script.
+#
+# Arguments:
+# args One or more arguments, the last of which must
+# be the script to evaluate.
+#
+# Results:
+# Returns the result of evaluating the script.
+
+DbgNub_procCmd debugger_eval {args} {
+ global DbgNub errorInfo errorCode
+ set length [llength $args]
+ set blockName ""
+ for {set i 0} {$i < $length} {incr i} {
+ set arg [lindex $args $i]
+ switch -glob -- $arg {
+ -name {
+ incr i
+ if {$i < $length} {
+ set blockName [lindex $args $i]
+ } else {
+ return -code error "missing argument for -name switch"
+ }
+ }
+ -- {
+ incr i
+ break
+ }
+ -* {
+ return -code error "bad switch \"$arg\": must be -block, or --"
+ }
+ default {
+ break
+ }
+ }
+ }
+ if {$i != $length-1} {
+ return -code error "wrong # args: should be \"debugger_eval ?options? script\""
+ }
+
+ set script [lindex $args $i]
+
+ if {$DbgNub(socket) != -1} {
+ set icode [DbgNub_Instrument $blockName $script]
+
+ # If the instrumentation failed, we just eval the original script
+
+ if {$icode == ""} {
+ set icode $script
+ }
+ } else {
+ set icode $script
+ }
+
+ set level [expr {[DbgNub_infoCmd level] - 1}]
+ DbgNub_PushContext $level "debugger_eval"
+ set marker [DbgNub_PushStack $level [list $level "debugger_eval"]]
+ set code [DbgNub_catchCmd {
+ DbgNub_uplevelCmd 1 $icode
+ } result options]
+ DbgNub_cleanErrorInfo
+ DbgNub_PopStack $marker
+ DbgNub_PopContext
+
+ return -code $code -errorcode $errorCode -errorinfo $errorInfo -options $options $result
+}
+
+# debugger_break --
+#
+# Cause the debugger to break on this command.
+#
+# Arguments:
+# str (Optional) String that displays in debugger.
+#
+# Results:
+# None. Will send break message to debugger.
+
+DbgNub_procCmd debugger_break {{str ""}} {
+ global DbgNub
+
+ set level [expr {[DbgNub_infoCmd level] - 1}]
+ if {$DbgNub(socket) != -1} {
+ DbgNub_Break $level userbreak $str
+ }
+
+ return
+}
+
+# debugger_attached --
+#
+# Test whether the debugger socket is still connected to the
+# debugger.
+#
+# Arguments:
+# None.
+#
+# Results:
+# Returns 1 if the debugger is still connected.
+
+DbgNub_procCmd debugger_attached {} {
+ global DbgNub
+
+ # Process queued messages to ensure that we notice a disconnect.
+ DbgNub_ProcessMessages 0
+ return [expr {$DbgNub(socket) != -1}]
+}
+
+# debugger_setCatchFlag --
+#
+# Set the catch flag to indicate if errors should be caught by the
+# debugger. This flag is normally set to 0 by the "catch" command.
+# This command can be used to reset the flag to allow errors to be
+# reported by the debugger even if they would normally be masked by a
+# enclosing catch command. Note that the catch flag can be overridden by
+# the errorAction flag controlled by the user's project settings.
+#
+# Arguments:
+# flag The new value of the flag. 1 indicates thtat errors should
+# be caught by the debugger. 0 indicates that the debugger
+# should allow errors to propagate.
+#
+# Results:
+# Returns the previous value of the catch flag.
+#
+# Side effects:
+# None.
+
+DbgNub_procCmd debugger_setCatchFlag {flag} {
+ global DbgNub
+
+ set old $DbgNub(catch)
+ set DbgNub(catch) $flag
+ return $old
+}
--- /dev/null
+# The Tcl debugger for Speare code editor.
+# Copyright (c) 1998-2000 Ajuba Solutions
+# Copyright (c) 2019 sevenuc.com. All rights reserved.
+#
+# THIS FILE IS PART OF SPEARE CODE EDITOR. WITHOUT THE
+# WRITTEN PERMISSION OF THE AUTHOR THIS FILE MAY NOT
+# BE USED FOR ANY COMMERCIAL PRODUCT.
+#
+# More info:
+# http://sevenuc.com/en/Speare.html
+# Contact:
+# Sevenuc support <info@sevenuc.com>
+# Issue report and requests pull:
+# https://github.com/chengdu/Speare
+
+
+# lassign --
+#
+# This function emulates the TclX lassign command.
+#
+# Arguments:
+# valueList A list containing the values to be assigned.
+# args The list of variables to be assigned.
+#
+# Results:
+# Returns any values that were not assigned to variables.
+
+if {[info commands lassign] eq {}} {
+
+# start lassign proc
+proc lassign {valueList args} {
+ if {[llength $args] == 0} {
+ error "wrong # args: lassign list varname ?varname..?"
+ #puts "wrong # args: lassign list varname ?varname..?"
+ #return {}
+ }
+
+ uplevel [list foreach $args $valueList {break}]
+ return [lrange $valueList [llength $args] end]
+}
+# end lassign proc
+
+}
+
+# matchKeyword --
+#
+# Find the unique match for a string in a keyword table and return
+# the associated value.
+#
+# Arguments:
+# table A list of keyword/value pairs.
+# str The string to match.
+# exact If 1, only exact matches are allowed, otherwise unique
+# abbreviations are considered valid matches.
+# varName The name of a variable that will hold the resulting value.
+#
+# Results:
+# Returns 1 on a successful match, else 0.
+
+proc matchKeyword {table str exact varName} {
+ upvar $varName result
+ if {$str == ""} {
+ foreach pair $table {
+ set key [lindex $pair 0]
+ if {$key == ""} {
+ set result [lindex $pair 1]
+ return 1
+ }
+ }
+ return 0
+ }
+ if {$exact} {
+ set end end
+ } else {
+ set end [expr {[string length $str] - 1}]
+ }
+ set found ""
+ foreach pair $table {
+ set key [lindex $pair 0]
+ if {[string compare $str [string range $key 0 $end]] == 0} {
+ # If the string matches exactly, return immediately.
+
+ if {$exact || ($end == ([string length $key]-1))} {
+ set result [lindex $pair 1]
+ return 1
+ } else {
+ lappend found [lindex $pair 1]
+ }
+ }
+ }
+ if {[llength $found] == 1} {
+ set result [lindex $found 0]
+ return 1
+ } else {
+ return 0
+ }
+}
+
--- /dev/null
+#!/usr/bin/env python
+# -*- coding: utf-8 -*-
+
+"""
+Copyright (C) 2019 Sevenuc Consulting
+http://sevenuc.com/en/Speare.html
+
+YOU CAN MODIFY THIS SCRIPT FOR PERSONAL USAGE FREELY, BUT
+USED IN ANY COMMERCIAL PRODUCT WITHOUT THE WRITTEN PERMISSION
+OF THE AUTHOR IS NOT ALLOWED.
+"""
+
+#This is a simple script that used to clean folders especially when you check
+#out source code from repository managed by version control systems, such as
+#Git, Mercurial, Subversion and CVS. It also delete all hidden file and folders
+#produced by compiler, build system and IDE that always cause your disk occupied
+#by large number of stuff that you don't want to keep anymore.
+
+import os, os.path
+import sys
+
+if (sys.version_info.major == 2):
+ reload(sys)
+ sys.setdefaultencoding('utf-8')
+
+all_hidden = False #delete all hidden folder and files
+build_libs = False #delete .deps and .libs folders
+
+ignores = ['.DS_Store'] #file or folder to ignore on macOS
+defiles = ['.cvsignore', '.hgignore', '.gitignore', '.circleci'] #list of files to delete
+folders = ['.git', '.gitmodules', '.gitignore', '.svn', '.hg'] #list of folders to delete
+extensions = ['.o', '.lo', '.la'] #file types to delete
+ignoredirs = ['/Users/henry/Desktop/Machine/1101/bitcoinbook.git', #don't scan the folders
+ '/Users/henry/Desktop/Sonora']
+
+#* Careful!! .d conflict with the D programming language files.
+#extensions.append('.d') #append .d files generated by CMake
+
+def clean_folder(dir):
+ global ignores, defiles, folders, extensions, ignoredirs
+ if build_libs:
+ folders.append('.deps')
+ folders.append('.libs')
+
+ for root, dirs, files in os.walk(dir):
+ for d in list(dirs):
+ if d in ['.', '..']: continue
+ if d in ignores: continue
+ fullpath = os.path.join(root, d)
+ if fullpath in ignoredirs: continue
+ if d[0] == '.':
+ if all_hidden or d in folders:
+ print(fullpath)
+ #os.rmdir(fullpath)
+ os.system('rm -rf "' + fullpath + '"')
+ elif d == 'CVS':
+ shoulddelete = True
+ for root, dirs, files in os.walk(fullpath):
+ a = ['Entries', 'Repository', 'Root', 'Entries.Log']
+ for name in a:
+ if not name in files: shoulddelete = False
+ if shoulddelete:
+ print(fullpath)
+ os.system('rm -rf "' + fullpath + '"')
+ elif d == 'DerivedData':
+ fullpath2 = os.path.join(root, "build")
+ if os.path.exists(fullpath2):
+ print(fullpath)
+ os.system('rm -rf "' + fullpath + '"')
+ print(fullpath2)
+ os.system('rm -rf "' + fullpath2 + '"')
+ else:
+ pass #if fullpath in ignoredirs: continue
+
+ for f in files:
+ if f in ignores: continue
+ fullpath = os.path.join(root, f)
+ ext = os.path.splitext(fullpath)[1]
+ if f in defiles or ext in extensions:
+ print(fullpath)
+ os.system('rm -rf "' + fullpath + '"')
+ if(all_hidden and f[0] == '.'):
+ print(fullpath)
+ #os.remove(fullpath)
+ os.system('rm -rf "' + fullpath + '"')
+
+def usage():
+ print('Usage: '+sys.argv[0]+' [-a] [-b] [-d folder]')
+ print(' -a, --all delete all hidden folder and files, default is false.')
+ print(' -b, --build delete all .deps and .libs folders, default is true.')
+ print(' -d, --dir the full path of the folder you want to clean.')
+ print(' e.g: '+sys.argv[0]+' -d "/Users/henry/Product/iCodeEditor/third-party"')
+ print(' e.g: '+sys.argv[0]+' -a True -d "/Users/henry/Product/Bamboo"')
+
+def main():
+ import argparse
+ parser = argparse.ArgumentParser(description=__doc__)
+ parser.add_argument('-a', '--all', dest='all_hidden', type=bool, default='False',
+ help='Delete all hidden folder and files, default is false.')
+ parser.add_argument('-b', '--build', dest='build_libs', type=bool, default='True',
+ help='Delete all .deps and .libs folders, default is true.')
+ parser.add_argument('-d', '--dir', dest='dir', type=str, default='',
+ help='The folder to clean')
+ parser.set_defaults(all_hidden=False)
+ args = parser.parse_args()
+
+ dir = args.dir
+ if len(dir) == 0:
+ usage()
+ return
+ all_hidden = args.all_hidden
+ clean_folder(dir)
+
+if __name__ == "__main__":
+ main()
+
--- /dev/null
+#!/bin/sh
+#kill process when address already in use
+port=6789
+if [ $# -eq 1 ]
+ then port=$1
+fi
+lsof -iTCP -sTCP:LISTEN -n -P | grep $port | awk '{print $2}'| xargs kill -9
+
--- /dev/null
+#! /usr/bin/env python
+
+# The C and C++ debugger for Speare code editor.
+# Copyright (c) 2019 sevenuc.com. All rights reserved.
+#
+# THIS FILE IS PART OF SPEARE CODE EDITOR. WITHOUT THE
+# WRITTEN PERMISSION OF THE AUTHOR THIS FILE MAY NOT
+# BE USED FOR ANY COMMERCIAL PRODUCT.
+#
+# More info:
+# http://sevenuc.com/en/Speare.html
+# Contact:
+# Sevenuc support <info@sevenuc.com>
+# Issue report and requests pull:
+# https://github.com/chengdu/Speare
+
+import os, re, sys
+import lldb
+import json
+import socket
+import time
+import thread
+import threading
+import platform
+import resource
+
+debugger = None
+new_breakpoints = []
+registered_breakpoints = set()
+# The configure file must be put together with this script
+configfile = "speare_lldb.json"
+
+class StepType:
+ INSTRUCTION = 1
+ INSTRUCTION_OVER = 2
+ INTO = 3
+ OVER = 4
+ OUT = 5
+
+def print_banner():
+ print("\n")
+ print(" ____")
+ print(" / __/ __ ___ ___ ___ ___")
+ print(" _\\ \\/ _ \\/ -_) _ `/ __/ -_)")
+ print(" /___/ .__/\\__/\\_,_/_/ \\__/")
+ print(" /_/")
+ print("Speare Debug Server v0.0.4")
+ print("(c) http://sevenuc.com \n")
+
+def breakpoint_callback(frame, bp_loc, dict):
+ # Ensure breakpoint contained in the frame be selected
+ global debugger
+ frame.thread.process.SetSelectedThread(frame.thread)
+ frame.thread.SetSelectedFrame(frame.idx)
+ debugger.sendPausedInfo(frame)
+ # Returning True means that we actually want to stop at this breakpoint
+ return True
+
+def pause_helper(frame):
+ line = str(frame)
+ #frame #0: 0x0000000100000edd hello`main at /your/source/path/hello.c:9
+ p = line.rfind(" at ")
+ if p != -1:
+ fileline = line[p+4:]
+ p = fileline.rfind(':')
+ if p != -1:
+ srcfile = fileline[:p]
+ return (srcfile, fileline[p+1:])
+ return None
+
+def notify_target(event):
+ global debugger
+ if event.GetType() & lldb.SBTarget.eBroadcastBitModulesLoaded != 0:
+ for i in xrange(lldb.SBTarget.GetNumModulesFromEvent(event)):
+ mod = lldb.SBTarget.GetModuleAtIndexFromEvent(i, event)
+ string = 'Module loaded: %s.' % mod.GetFileSpec().fullpath
+ if mod.GetSymbolFileSpec().IsValid():
+ string += ' Symbols loaded.'
+ debugger.message(string)
+
+def notify_stdio(ev_type):
+ global debugger
+ if ev_type == lldb.SBProcess.eBroadcastBitSTDOUT:
+ read_stream = debugger.process.GetSTDOUT
+ isStdout = True
+ else:
+ read_stream = debugger.process.GetSTDERR
+ isStdout = False
+ output = read_stream(1024)
+ while output:
+ # TODO: you can hook here to log big data output or error in file.
+ debugger.message(output)
+ output = read_stream(1024)
+
+def start_loop_listener():
+ global debugger
+ listener = lldb.SBListener("loop listener")
+ def listen():
+ event = lldb.SBEvent()
+ while True:
+ if listener.WaitForEvent(1, event):
+ #if lldb.SBProcess.EventIsProcessEvent(event):
+ # print("process event")
+ ev_type = event.GetType()
+ if ev_type & (lldb.SBProcess.eBroadcastBitSTDOUT | lldb.SBProcess.eBroadcastBitSTDERR) != 0:
+ notify_stdio(ev_type)
+ elif lldb.SBTarget.EventIsTargetEvent(event):
+ notify_target(event)
+ listener_thread = threading.Thread(target=listen)
+ listener_thread.daemon = True
+ listener_thread.start()
+ if not debugger.process.IsValid():
+ print('Error: process is invalid when running loop listener.')
+ sys.exit(0)
+ debugger.process.GetBroadcaster().AddListener(listener, 0xFFFFFF)
+
+def start_breakpoint_listener():
+ # Listens for breakpoints event
+ global debugger
+ listener = lldb.SBListener("breakpoint listener")
+
+ def listen():
+ event = lldb.SBEvent()
+ try:
+ while True:
+ #TODO: add an option in configure file, default 120
+ if listener.WaitForEvent(120, event):
+ if lldb.SBBreakpoint.EventIsBreakpointEvent(event) and \
+ lldb.SBBreakpoint.GetBreakpointEventTypeFromEvent(event) == \
+ lldb.eBreakpointEventTypeAdded:
+ breakpoint = lldb.SBBreakpoint.GetBreakpointFromEvent(event)
+ global debugger, new_breakpoints
+ new_breakpoints.append(breakpoint.id)
+ file = None; line = None
+ string = str(breakpoint)
+ #SBBreakpoint: id = 2, file = '/your/source/path/hello.c', line = 14
+ for item in string.split(', '):
+ if item.startswith('file = '):
+ file = item[8:-1]
+ elif item.startswith('line = '):
+ line = item[7:]
+ if file and line: break
+ if file and line:
+ temp = '{"command": "breakpoint", "id": %s, "file": "%s", "line": %s}'
+ debugger.message(temp % (str(breakpoint.id), file, line))
+ except:
+ print("*** Breakpoint listener shutting down")
+ listener_thread = threading.Thread(target=listen)
+ listener_thread.daemon = True
+ listener_thread.start()
+ broadcaster = debugger.target.GetBroadcaster()
+ broadcaster.AddListener(listener, lldb.SBTarget.eBroadcastBitBreakpointChanged)
+
+class LLDBDebugger(object):
+ eventDelayStep = 2
+ eventDelayLaunch = 1
+ eventDelayContinue = 1
+
+ def __init__(self, sock, lstener, config):
+ self.target = None
+ self.process = None
+ self.load_dependent_modules = True
+ self.listener = lstener
+ self.socket = sock
+ self.queue = []
+ self.queue_lock = threading.Lock()
+ self.mappathchecked = False
+ self.configdict = config
+ self.show_disassembly = None
+ self.dbg = lldb.SBDebugger.Create()
+ self.commandInterpreter = self.dbg.GetCommandInterpreter()
+ self.setSettings()
+
+ def handleSettings(self, string):
+ self.commandInterpreter.HandleCommand(str(string), lldb.SBCommandReturnObject())
+
+ def setSettings(self):
+ self.handleSettings("settings set target.inline-breakpoint-strategy always")
+ self.handleSettings("settings set frame-format frame #${frame.index}: " \
+ "${frame.pc}{ ${module.file.basename}{\`${function.name}}}" \
+ "{ at ${line.file.fullpath}:${line.number}}\n")
+ self.handleSettings("settings set target.load-script-from-symbol-file false")
+
+ def remapSourcePath(self, srcfile):
+ # If the build path of the program WAS NOT
+ # the same path for the debug session use the running path instead of the build path
+ # debugger.handleSettings("settings set target.source-map /buildbot/path /my/path")
+ runnning_dir = self.configdict['remappath']
+ if runnning_dir[0] == '#': return # remap path not set
+ compile_dir = os.path.dirname(srcfile)
+ self.handleSettings("settings set target.source-map %s %s" % (compile_dir, runnning_dir))
+
+ def message(self, data):
+ self.socket.sendall(data + '\r\n')
+
+ def addRequest(self, req):
+ self.queue_lock.acquire()
+ self.queue.append(req)
+ self.queue_lock.release()
+
+ def filespecToLocal(self, filespec):
+ if not filespec.IsValid():
+ return None
+ local_path = os.path.normpath(filespec.fullpath)
+ if not os.path.isfile(local_path):
+ local_path = None
+ return local_path
+
+ # Should we show source or disassembly for this frame
+ def inDisassembly(self, frame):
+ if self.show_disassembly == 'never':
+ return False
+ elif self.show_disassembly == 'always':
+ return True
+ else:
+ fs = frame.GetLineEntry().GetFileSpec()
+ return self.filespecToLocal(fs) is None
+
+ def doStep(self, stepType):
+ target = self.dbg.GetSelectedTarget()
+ process = target.GetProcess()
+ t = process.GetSelectedThread()
+ if stepType == StepType.INTO:
+ if not self.inDisassembly(t.GetFrameAtIndex(0)):
+ t.StepInto()
+ else:
+ t.StepInstruction(False) # StepType.INSTRUCTION
+ elif stepType == StepType.OVER:
+ if not self.inDisassembly(t.GetFrameAtIndex(0)):
+ t.StepOver()
+ else:
+ t.StepInstruction(True) # StepType.INSTRUCTION_OVER
+ elif stepType == StepType.OUT:
+ t.StepOut()
+ self.processPendingEvents(self.eventDelayStep, True)
+
+ def doSelect(self, command, args):
+ # Like doCommand, but suppress output when "select" is the first argument.
+ a = args.split(' ')
+ return self.doCommand(command, args, "select" != a[0], True)
+
+ def doProcess(self, args):
+ # Handle 'process' command. If 'launch' is requested, use doLaunch() instead
+ # of the command interpreter to start the inferior process.
+ a = args.split(' ')
+ if len(args) == 0 or (len(a) > 0 and a[0] != 'launch'):
+ self.doCommand("process", args)
+ else:
+ self.doLaunch('-s' not in args, "")
+
+ def doAttach(self, process_name):
+ error = lldb.SBError()
+ self.processListener = lldb.SBListener("process_event_listener")
+ self.target = self.dbg.CreateTarget('')
+ self.process = self.target.AttachToProcessWithName(self.processListener, process_name, False, error)
+ if not error.Success():
+ print("Error during attach: " + str(error))
+ return
+ self.pid = self.process.GetProcessID()
+ print("Attached %s (pid=%d)" % (process_name, self.pid))
+
+ def doDetach(self):
+ if self.process is not None and self.process.IsValid():
+ pid = self.process.GetProcessID()
+ self.process.Detach()
+ self.processPendingEvents(self.eventDelayLaunch)
+
+ def doLaunch(self, stop_at_entry, args):
+ error = lldb.SBError()
+ fs = self.target.GetExecutable()
+ exe = os.path.join(fs.GetDirectory(), fs.GetFilename())
+ if self.process is not None and self.process.IsValid():
+ pid = self.process.GetProcessID()
+ self.process.Destroy()
+ launchInfo = lldb.SBLaunchInfo(args.split(' '))
+ self.process = self.target.Launch(launchInfo, error)
+ if not error.Success():
+ print("Error during launch: " + str(error))
+ return
+ # launch succeeded, store pid and add some event listeners
+ self.pid = self.process.GetProcessID()
+ self.processListener = lldb.SBListener("process_event_listener")
+ self.process.GetBroadcaster().AddListener(self.processListener, \
+ lldb.SBProcess.eBroadcastBitStateChanged)
+ start_loop_listener()
+
+ # Limits debugger's memory usage to 4GB to prevent machine crash
+ if self.configdict['memorylimits_enable']:
+ soft, hard = resource.getrlimit(resource.RLIMIT_AS)
+ limits = 4 # 4GB by default
+ try:
+ memorylimits = self.configdict['memorylimits']
+ if memorylimits.endswith('GB'): memorylimits = memorylimits[:-2]
+ limits = int(memorylimits)
+ except: pass
+ resource.setrlimit(resource.RLIMIT_AS, (limits * 1024**3, hard))
+
+ print("Launched %s (pid=%d)" % (exe, self.pid))
+ if not stop_at_entry:
+ self.doContinue()
+ else:
+ self.processPendingEvents(self.eventDelayLaunch)
+
+ def doTarget(self, args):
+ target_args = [ "delete", "list", "modules", "select", "stop-hook", "symbols", "variable"]
+ a = args.split(' ')
+ if len(args) == 0 or (len(a) > 0 and a[0] in target_args):
+ print("args=%s" % args)
+ self.doCommand("target", str(args))
+ return
+ elif len(a) > 1 and a[0] == "create":
+ exe = a[1]
+ elif len(a) == 1 and a[0] not in target_args:
+ exe = a[0]
+ err = lldb.SBError()
+ self.target = self.dbg.CreateTarget(str(exe), None, None, self.load_dependent_modules, err)
+ if not self.target:
+ print("Error creating target %s. %s" % (str(exe), str(err)))
+ return
+
+ def sendPausedInfo(self, frame):
+ if frame.IsInlined(): return None
+ temp = '{"command": "paused", "file": "%s", "line": %d}'
+ filespec = frame.GetLineEntry().GetFileSpec()
+ srcfile = filespec.fullpath #os.path.normpath(filespec.fullpath)
+ if srcfile:
+ line = frame.GetLineEntry().GetLine()
+ self.message(temp % (srcfile, line))
+ else:
+ fileline = pause_helper(frame)
+ if fileline:
+ srcfile = fileline[0]
+ self.message(temp % (fileline[0], fileline[1]))
+ return srcfile
+
+ def doContinue(self):
+ #TODO:switch to doCommand("continue", ...) to handle -i ignore-count param.
+ if not self.process or not self.process.IsValid():
+ print("No process to continue.")
+ return
+ self.process.Continue()
+ self.processPendingEvents(self.eventDelayContinue)
+ self.registerBreakpoint()
+
+ def doRefresh(self):
+ status = self.processPendingEvents()
+
+ def doExit(self, tracback = False):
+ if not self.process: return
+ if tracback: # print stack data when crashed
+ self.printFrames()
+ self.traceAll(True)
+
+ self.dbg.Terminate()
+ self.dbg = None
+ if self.listener: self.listener.close()
+ if self.socket: self.socket.close()
+ self.process.Kill()
+ self.process = None
+
+ def getCommandResult(self, command, command_args = ""):
+ result = lldb.SBCommandReturnObject()
+ cmd = "%s %s" % (command, command_args)
+ self.commandInterpreter.HandleCommand(cmd, result)
+ return (result.Succeeded(), result)
+
+ def doCommand(self, command, command_args, print_on_success = True, goto_file=False):
+ (success, result) = self.getCommandResult(command, command_args)
+ output = result.GetOutput() if result.Succeeded() else result.GetError()
+ if success:
+ #if command == "breakpoint": #hook breakpoint call
+ # self.breakpoint_post_handle(result, command_args)
+ if (output and len(output) > 0) and print_on_success:
+ print(output)
+ else:
+ print(output + "\n")
+
+ def registerBreakpoint(self):
+ res = lldb.SBCommandReturnObject()
+ while len(new_breakpoints) > 0:
+ res.Clear()
+ breakpoint_id = new_breakpoints.pop()
+ if breakpoint_id in registered_breakpoints:
+ pass #breakpoint with id xxx is already registered. Ignoring.
+ else:
+ bpid = str(breakpoint_id)
+ # make sure to register them with the breakpoint callback
+ callback_command = ("breakpoint command add -F breakpoint_callback " + bpid)
+ self.commandInterpreter.HandleCommand(callback_command, res)
+ if res.Succeeded():
+ registered_breakpoints.add(breakpoint_id)
+ else:
+ print("Error while trying to register breakpoint callback, id = " + bpid)
+
+ def processPendingEvents(self, wait_seconds=0, goto_file=True):
+ # Handle any events that are queued from the inferior.
+ # Blocks for at most wait_seconds, or if wait_seconds == 0,
+ # process only events that are already queued.
+ status = None
+ num_events_handled = 0
+
+ if self.process is not None:
+ event = lldb.SBEvent()
+ old_state = self.process.GetState()
+ new_state = None
+ done = False
+ if old_state == lldb.eStateInvalid or old_state == lldb.eStateExited:
+ # Early-exit if we are in 'boring' states
+ pass
+ else:
+ while not done and self.processListener is not None:
+ if not self.processListener.PeekAtNextEvent(event):
+ if wait_seconds > 0:
+ # No events on the queue, but we are allowed to wait for wait_seconds
+ # for any events to show up.
+ self.processListener.WaitForEvent(wait_seconds, event)
+ new_state = lldb.SBProcess.GetStateFromEvent(event)
+ num_events_handled += 1
+ done = not self.processListener.PeekAtNextEvent(event)
+ else:
+ # An event is on the queue, process it here.
+ self.processListener.GetNextEvent(event)
+ new_state = lldb.SBProcess.GetStateFromEvent(event)
+
+ # continue if stopped after attaching
+ if old_state == lldb.eStateAttaching and new_state == lldb.eStateStopped:
+ self.process.Continue()
+
+ # If needed, perform any event-specific behaviour here
+ num_events_handled += 1
+
+ ev_type = event.GetType()
+ if ev_type & (lldb.SBProcess.eBroadcastBitSTDOUT | lldb.SBProcess.eBroadcastBitSTDERR) != 0:
+ self.notify_stdio(ev_type)
+
+ if num_events_handled == 0:
+ pass
+ else:
+ if new_state == lldb.eStateCrashed or new_state == lldb.eStateExited:
+ print("\n*** process exited.\n")
+ self.doExit(new_state == lldb.eStateCrashed)
+
+ def dumpGlobals(self):
+ if not self.target: return
+ module = self.target.module[self.target.executable.basename]
+ if not module: return
+ items = list()
+ global_names = list()
+ for symbol in module.symbols:
+ if symbol.type == lldb.eSymbolTypeData:
+ global_name = symbol.name
+ if global_name not in global_names:
+ global_names.append(global_name)
+ global_variable_list = module.FindGlobalVariables(self.target, global_name, lldb.UINT32_MAX)
+ if global_variable_list:
+ for global_variable in global_variable_list:
+ items.append('{"%s": {"type": "%s", "value": "%s"}}' % \
+ (global_variable.name, global_variable.type, global_variable.value))
+ return items
+
+ """
+ def dumpSBValue(self, sbvalue):
+ children = []
+ for i in range(sbvalue.GetNumChildren()):
+ x = sbvalue.GetChildAtIndex(i, lldb.eNoDynamicValues, True)
+ if isinstance(x, dict) or isinstance(x, list):
+ s = self.dumpSBValue(x)
+ else: s = str(x)
+ children.append(s)
+ return children
+ """
+
+ def disasm(self, frame):
+ def disassemble_instructions (insts):
+ for i in insts:
+ print i
+ print("~~~~~~~~~")
+ print frame # print the frame summary
+ function = frame.GetFunction()
+ # see if we have debug info (a function)
+ if function:
+ # print some info for the function
+ print function
+ # nNow get all instructions for this function and print them
+ insts = function.GetInstructions(target)
+ disassemble_instructions (insts)
+ else:
+ # see if we have a symbol in the symbol table for where we stopped
+ symbol = frame.GetSymbol();
+ if symbol:
+ # we do have a symbol, print some info for the symbol
+ print symbol
+ # now get all instructions for this symbol and print them
+ insts = symbol.GetInstructions(target)
+ disassemble_instructions (insts)
+
+ registerList = frame.GetRegisters()
+ print('Frame registers (size of register set = %d):' % registerList.GetSize())
+ for value in registerList:
+ print value
+ print('%s (number of children = %d):' % (value.GetName(), value.GetNumChildren()))
+ for child in value:
+ print('Name: ', child.GetName(), ' Value: ', child.GetValue())
+ print("~~~~~~~~~")
+
+ def traceAll(self, force = False):
+ if not self.dbg: return
+ target = self.dbg.GetSelectedTarget()
+ process = target.GetProcess()
+ thread = process.GetSelectedThread()
+ #thread = process.GetThreadAtIndex(0)
+
+ #1. Dump image symbol address:
+ if force or self.configdict['dumpimage']:
+ (success, result) = self.getCommandResult("image", "list")
+ if success: print(result.GetOutput())
+
+ #2. Display registers
+ if force or self.configdict['dumpregisters']:
+ (success, result) = self.getCommandResult("register", "read")
+ if success: print(result.GetOutput())
+ frame = thread.GetFrameAtIndex(0)
+ if frame: self.disasm(frame)
+
+ #3. Trace back threads
+ if not force and not self.configdict['dumpframes']:
+ return
+ (success, result) = self.getCommandResult("thread", "backtrace")
+ if success: print(result.GetOutput())
+
+ #4. Dump all frames of current thread
+ print("Current Frames:")
+ for frame in thread:
+ if not frame.IsInlined():
+ print(frame)
+ print("frame.pc = 0x%16.16x" % frame.pc)
+ function = frame.GetFunction()
+ if function: #'No value'
+ print(function)
+ vars = frame.get_all_variables()
+ for var in vars: print(var)
+ args = frame.get_arguments()
+ for arg in args: print(arg)
+ print("---------------")
+
+ def dumpArgsAndVariables(self, name, args, stack):
+ if len(args):
+ argstring = []
+ for arg in args:
+ argstring.append('{"%s": {"type": "%s", "value": "%s"}}' % (arg.name, arg.type, arg.value))
+ stack.append('"' + name + '": [\n' + ',\n'.join(argstring) + '],')
+
+ def printFrames(self):
+ if not self.dbg: return
+ target = self.dbg.GetSelectedTarget()
+ process = target.GetProcess()
+ thread = process.GetSelectedThread()
+
+ stack = []
+ #frame = thread.GetSelectedFrame()
+ frame = thread.GetFrameAtIndex(0)
+ if frame:
+ srcfile = self.sendPausedInfo(frame)
+ if not frame.IsInlined():
+ # Map source dir
+ if srcfile and not self.mappathchecked:
+ self.remapSourcePath(srcfile)
+ self.mappathchecked = True
+
+ #SBFunction: id = 0x0000011c, name = main, type = main
+ function = frame.GetFunctionName() #frame.GetFunction()
+ if function:
+ stack.append('"function": "%s",' % function)
+
+ args = frame.get_arguments()
+ self.dumpArgsAndVariables("args", args, stack)
+ vars = frame.get_all_variables()
+ self.dumpArgsAndVariables("vars", vars, stack)
+
+ globalvars = self.dumpGlobals()
+ if len(globalvars):
+ stack.append('"global": [\n' + ',\n'.join(globalvars) + '],')
+ if len(stack):
+ self.message('{\n "command": "stack",\n' + '\n'.join(stack) + '\n}')
+
+ def doRequest(self, line):
+ if not line or len(line) == 0:
+ return
+ try:
+ d = json.loads(line)
+ except ValueError:
+ return
+ if not d: return
+ cmd = d['command']
+
+ if cmd == 'step':
+ args = d['args']
+ if args == 'into': stepType = StepType.INTO
+ elif args == 'over': stepType = StepType.OVER
+ elif args == 'out': stepType = StepType.OUT
+ else: return;
+ self.doStep(stepType)
+ self.printFrames()
+ self.traceAll() # TODO: more hook info here.
+ elif cmd == 'continue':
+ self.doContinue()
+ elif cmd == 'breakpoint':
+ args = d['args']
+ self.doCommand("breakpoint", str(args), True, True)
+ elif cmd == 'exit':
+ self.doExit()
+ elif cmd == 'attach':
+ process_name = d['process_name']
+ self.doAttach(str(process_name))
+ elif cmd == 'dettach':
+ self.doDetach()
+ else: # other command
+ args = d['args'] or ""
+ #print("command: %s %s" % (cmd, args))
+ self.doCommand(cmd, str(args))
+
+ def handelRequest(self):
+ if not self.process: return
+ #TODO: handle exit gracefully
+ state = self.process.GetState()
+ if state in [lldb.eStateInvalid, lldb.eStateCrashed, lldb.eStateExited]:
+ self.doExit(state == lldb.eStateCrashed)
+ return
+
+ self.queue_lock.acquire()
+ if len(self.queue) > 0:
+ for req in self.queue:
+ self.doRequest(req)
+ self.doRefresh()
+ self.registerBreakpoint()
+ self.queue.remove(req)
+ self.queue_lock.release()
+
+#end class
+
+def main():
+ port = 6789
+ global debugger
+ if not platform.system() == 'Darwin':
+ print('Invalid operation system.')
+ sys.exit(0)
+ fp = open(configfile, 'r')
+ if not fp:
+ print("Can't find %s." % configfile)
+ sys.exit(0)
+ dict = json.load(fp)
+ fp.close()
+
+ try: port = int(dict['port'])
+ except:
+ print('Invalid port number: "%s".' % dict['port'])
+ sys.exit(0)
+ executable = dict['program']
+ if not os.path.exists(executable):
+ print('Invalid image: %s' % executable)
+ sys.exit(0)
+ listener = socket.socket(socket.AF_INET, socket.SOCK_STREAM)
+ server_address = ('localhost', port)
+ listener.bind(server_address) # Address already in use
+ listener.listen(1) # Listen for incoming connection
+ print_banner()
+ print('Listen on port %d ...' % port)
+ print('image: %s' % executable)
+
+ connection, client_address = listener.accept()
+ #connection.setsockopt(socket.IPPROTO_TCP, socket.TCP_NODELAY, 1)
+ debugger = LLDBDebugger(connection, listener, dict)
+ debugger.handleSettings("settings set target.env-vars DEBUG=1")
+ for item in dict['environment']:
+ k = item.keys()[0]
+ #TODO: some value should be quoted
+ debugger.handleSettings("settings set target.env-vars %s=%s" % (k, item[k]))
+ cmdline = 'create %s %s' % (executable, ' '.join(dict['args']))
+ debugger.doTarget(cmdline)
+ #dSYMFile = dict['dSYM'] # TODO: handle customised symbols dir
+ #if os.path.exists(dSYMFile):
+ # debugger.doTarget('symbols %s' % dSYMFile) #invalid command
+ p = executable.rfind('/')
+ if p != -1: extradir = executable[:p]
+ else: extradir = os.path.dirname(os.path.realpath(__file__))
+ debugger.handleSettings("settings append target.exec-search-paths %s" % extradir)
+ debugger.doCommand('b', "main", True, True) # add breakpoint on main()
+ debugger.doLaunch(True, executable)
+ start_breakpoint_listener() # hook breakpoint calls
+
+ try:
+ while True:
+ data = connection.recv(1024) # Receive command from Speare
+ if not data: break
+ lines = data.decode('utf-8').split('\n')
+ for line in lines:
+ if len(line) > 0:
+ debugger.addRequest(line)
+ debugger.handelRequest()
+ except socket.error:
+ force = False
+ if debugger.process:
+ state = debugger.process.GetState()
+ force = state == lldb.eStateCrashed
+ debugger.doExit(force)
+ finally:
+ if listener: listener.close()
+ if connection: connection.close()
+
+if __name__ == "__main__":
+ main()
+
+
--- /dev/null
+Speare Debug Server v0.0.4
+Copyright (c) 2019 sevenuc.com. All rights reserved.
+
+This is the C and C++ debugger for Speare code editor:
+http://sevenuc.com/en/Speare.html
+
+Package source and download:
+https://github.com/chengdu/Speare
+https://sourceforge.net/projects/speare
+http://sevenuc.com/download/c_debugger.tar.gz
+
+Package Content:
+
+lldb_debugger
+|____speare_lldb.json # The template of configure file
+|____lldb_debugger.py # The main debugger source code
+|____killproc.sh # shell script to kill Python process
+|____server.sh # shell script to start up debug server
+|____readme.txt # this file, readme for this package
+
+
+Configure File:
+{
+ "port": 6789, # The socket communication port both used by the debugger and Speare code editor.
+ "program": "/path/to/your/binary", # Full path of your binary
+ "remappath": "# /your/running/path", # Source code directory <-- very important
+ "args": ["one", "two", "three"], # Command line parameters
+ "environment": [{"name1": "value1"}, {"name2": "value2"}], # Environment variables
+ "dSYM": "/your/binary/path/hello.dSYM", # Not used at present
+ "memorylimits": "4GB", # Limits of memory usage by the debugger
+ "memorylimits_enable": true, # Turn on or off memory limits
+ "dumpimage": false, # Dump binary dependency
+ "dumpregisters": false, # Dump CPU registers
+ "dumpframes": false # Dump stack frames whenever debugger handle a command
+}
+
+
+Start Debug Server:
+
+0. Compile C or C++ source files with -g option and without optimisation option -O or use -O0
+ $ clang -g a.c b.c c.c -o hello
+ $ clang++ -g a.cxx b.cxx c.cxx -o hello
+
+ E.g:
+ $ clang -g -o exp.o -c exp.c
+ $ clang -g -o hello.o -c hello.c
+ $ clang -o hello exp.o hello.o
+
+1. generate debug symbol files:
+ $ /usr/bin/dsymutil executable -o executable.dSYM
+
+2. Set up configure file for the debugging program.
+ make a copy of the file speare_lldb.json and check each option carefully.
+
+3. Organising debugging directory.
+ ensure the binary executable and .dSYM file both in the same folder.
+ src # c or c++ source code
+ hello # the binary
+ hello.dSYM # the symbols file
+
+4. Run the start up shell script.
+ $ chmod 777 server.sh
+ $ bash ./server.sh
+
+
+Oct 30 2019
+
+
+
+
+
--- /dev/null
+#!/bin/bash
+
+# start up Speare Debug Server for lldb
+if ! [[ $PATH == *"/System/Library/Frameworks/Python.framework/Versions/2.7/bin"* ]]; then
+ export PATH=/System/Library/Frameworks/Python.framework/Versions/2.7/bin:$PATH
+fi
+
+export PYTHONPATH=/Applications/Xcode.app/Contents/SharedFrameworks/LLDB.framework/Resources/Python
+python2.7 lldb_debugger.py
+
--- /dev/null
+{
+ "port": 6789,
+ "program": "/your/binary/path/hello",
+ "args": ["one", "two", "three"],
+ "environment": [{"name1": "value1"}, {"name2": "value2"}],
+ "dSYM": "/your/binary/path/hello.dSYM",
+ "memorylimits": "4GB",
+ "memorylimits_enable": true,
+ "remappath": "# /your/running/path",
+ "dumpimage": false,
+ "dumpregisters": false,
+ "dumpframes": false
+}
+
--- /dev/null
+#!/usr/bin/perl
+
+# A generic Perl debugger for Speare Pro.
+# Copyright (c) 2019 sevenuc.com. All rights reserved.
+#
+# THIS FILE IS PART OF THE ADVANCED VERSION OF SPEARE CODE EDITOR.
+# WITHOUT THE WRITTEN PERMISSION OF THE AUTHOR THIS FILE MAY NOT
+# BE USED FOR ANY COMMERCIAL PRODUCT.
+#
+# More info:
+# http://sevenuc.com/en/Speare.html
+# Contact:
+# Sevenuc support <info@sevenuc.com>
+# Issue report and requests pull:
+# https://github.com/chengdu/Speare
+
+package Debugger;
+
+use IO::Socket::INET;
+
+binmode STDIN, ':utf8';
+binmode STDOUT, ':utf8';
+binmode STDERR, ':utf8';
+
+# flush after every write
+$| = 1;
+my ($socket, $client_socket);
+
+BEGIN {
+ require "perl5db.pl";
+}
+
+sub start_server{
+ my ($peeraddress, $peerport);
+ # socket creation, binding and listening at the specified port.
+ $socket = new IO::Socket::INET (
+ LocalHost => '127.0.0.1',
+ LocalPort => '5000', #remember to set on Speare code editor side if change this value.
+ Proto => 'tcp',
+ Listen => 5,
+ Reuse => 1
+ ) or die "ERROR in Socket Creation : $!\n";
+
+ print "*** Waiting for connection on port 5000.\n";
+ # waiting for new client connection.
+ $client_socket = $socket->accept();
+ # get the host and port number of newly connected client.
+ $peer_address = $client_socket->peerhost();
+ $peer_port = $client_socket->peerport();
+ print "New connection accepted. \n";
+
+ STDOUT->fdopen($client_socket, "w");
+ STDERR->fdopen($client_socket, "w");
+
+ my $sysdir;
+ foreach my $t (@INC) {
+ if (-e "$t/perl5db.pl"){
+ $sysdir = $t;
+ last;
+ }
+ }
+
+ $dbutil::workdir = $sysdir;
+ $dbutil::perlsys = "/Library/Perl";
+ $dbutil::perlsysdir = "/System/Library/Perl";
+
+ $DB::frame = 4;
+ $DB::trace = 0; # AutoTrace
+ $DB::OUT = $client_socket;
+ $DB::IN = $client_socket;
+ $DB::tty = $DB::LINEINFO = $client_socket;
+
+};
+
+start_server();
+
+1;
+
--- /dev/null
+#!/usr/bin/perl
+
+# A generic Perl debugger for Speare Pro.
+# Copyright (c) 2019 sevenuc.com. All rights reserved.
+#
+# THIS FILE IS PART OF THE ADVANCED VERSION OF SPEARE CODE EDITOR.
+# WITHOUT THE WRITTEN PERMISSION OF THE AUTHOR THIS FILE MAY NOT
+# BE USED FOR ANY COMMERCIAL PRODUCT.
+#
+# More info:
+# http://sevenuc.com/en/Speare.html
+# Contact:
+# Sevenuc support <info@sevenuc.com>
+# Issue report and requests pull:
+# https://github.com/chengdu/Speare
+
+package dbutil;
+
+#use File::Basename;
+
+use vars qw(
+ $workdir
+ $perlsys
+ $perlsysdir
+);
+
+sub isexludedpath{
+ my $f = shift;
+
+ if ($f eq "perl5db.pl" or $f eq $workdir.. "/perl5db.pl") {
+ return 1;
+ }
+
+# my $dirname = dirname($f);
+# foreach my $dir ($perlsys, $perlsysdir, $workdir){
+# if ($dir =~ m/^$dirname/){
+# return 1;
+# }
+# }
+
+ # e.g. (eval 8)[/System/Library/Perl
+ if ($f =~ m/^\(eval\s(\d+)\)\[/){
+ return 1;
+ }
+
+ return 0;
+}
+
+1;
+
--- /dev/null
+#!/usr/bin/perl
+
+# A generic Perl debugger for Speare Pro.
+# Copyright (c) 2019 sevenuc.com. All rights reserved.
+#
+# THIS FILE IS PART OF THE ADVANCED VERSION OF SPEARE CODE EDITOR.
+# WITHOUT THE WRITTEN PERMISSION OF THE AUTHOR THIS FILE MAY NOT
+# BE USED FOR ANY COMMERCIAL PRODUCT.
+#
+# More info:
+# http://sevenuc.com/en/Speare.html
+# Contact:
+# Sevenuc support <info@sevenuc.com>
+# Issue report and requests pull:
+# https://github.com/chengdu/Speare
+
+
+=head1 NAME
+
+perl5db.pl - the perl debugger
+
+=head1 SYNOPSIS
+
+ perl -d your_Perl_script
+
+=head1 DESCRIPTION
+
+C<perl5db.pl> is the perl debugger. It is loaded automatically by Perl when
+you invoke a script with C<perl -d>. This documentation tries to outline the
+structure and services provided by C<perl5db.pl>, and to describe how you
+can use them.
+
+=head1 GENERAL NOTES
+
+The debugger can look pretty forbidding to many Perl programmers. There are
+a number of reasons for this, many stemming out of the debugger's history.
+
+When the debugger was first written, Perl didn't have a lot of its nicer
+features - no references, no lexical variables, no closures, no object-oriented
+programming. So a lot of the things one would normally have done using such
+features was done using global variables, globs and the C<local()> operator
+in creative ways.
+
+Some of these have survived into the current debugger; a few of the more
+interesting and still-useful idioms are noted in this section, along with notes
+on the comments themselves.
+
+=head2 Why not use more lexicals?
+
+Experienced Perl programmers will note that the debugger code tends to use
+mostly package globals rather than lexically-scoped variables. This is done
+to allow a significant amount of control of the debugger from outside the
+debugger itself.
+
+Unfortunately, though the variables are accessible, they're not well
+documented, so it's generally been a decision that hasn't made a lot of
+difference to most users. Where appropriate, comments have been added to
+make variables more accessible and usable, with the understanding that these
+I<are> debugger internals, and are therefore subject to change. Future
+development should probably attempt to replace the globals with a well-defined
+API, but for now, the variables are what we've got.
+
+=head2 Automated variable stacking via C<local()>
+
+As you may recall from reading C<perlfunc>, the C<local()> operator makes a
+temporary copy of a variable in the current scope. When the scope ends, the
+old copy is restored. This is often used in the debugger to handle the
+automatic stacking of variables during recursive calls:
+
+ sub foo {
+ local $some_global++;
+
+ # Do some stuff, then ...
+ return;
+ }
+
+What happens is that on entry to the subroutine, C<$some_global> is localized,
+then altered. When the subroutine returns, Perl automatically undoes the
+localization, restoring the previous value. Voila, automatic stack management.
+
+The debugger uses this trick a I<lot>. Of particular note is C<DB::eval>,
+which lets the debugger get control inside of C<eval>'ed code. The debugger
+localizes a saved copy of C<$@> inside the subroutine, which allows it to
+keep C<$@> safe until it C<DB::eval> returns, at which point the previous
+value of C<$@> is restored. This makes it simple (well, I<simpler>) to keep
+track of C<$@> inside C<eval>s which C<eval> other C<eval's>.
+
+In any case, watch for this pattern. It occurs fairly often.
+
+=head2 The C<^> trick
+
+This is used to cleverly reverse the sense of a logical test depending on
+the value of an auxiliary variable. For instance, the debugger's C<S>
+(search for subroutines by pattern) allows you to negate the pattern
+like this:
+
+ # Find all non-'foo' subs:
+ S !/foo/
+
+Boolean algebra states that the truth table for XOR looks like this:
+
+=over 4
+
+=item * 0 ^ 0 = 0
+
+(! not present and no match) --> false, don't print
+
+=item * 0 ^ 1 = 1
+
+(! not present and matches) --> true, print
+
+=item * 1 ^ 0 = 1
+
+(! present and no match) --> true, print
+
+=item * 1 ^ 1 = 0
+
+(! present and matches) --> false, don't print
+
+=back
+
+As you can see, the first pair applies when C<!> isn't supplied, and
+the second pair applies when it is. The XOR simply allows us to
+compact a more complicated if-then-elseif-else into a more elegant
+(but perhaps overly clever) single test. After all, it needed this
+explanation...
+
+=head2 FLAGS, FLAGS, FLAGS
+
+There is a certain C programming legacy in the debugger. Some variables,
+such as C<$single>, C<$trace>, and C<$frame>, have I<magical> values composed
+of 1, 2, 4, etc. (powers of 2) OR'ed together. This allows several pieces
+of state to be stored independently in a single scalar.
+
+A test like
+
+ if ($scalar & 4) ...
+
+is checking to see if the appropriate bit is on. Since each bit can be
+"addressed" independently in this way, C<$scalar> is acting sort of like
+an array of bits. Obviously, since the contents of C<$scalar> are just a
+bit-pattern, we can save and restore it easily (it will just look like
+a number).
+
+The problem, is of course, that this tends to leave magic numbers scattered
+all over your program whenever a bit is set, cleared, or checked. So why do
+it?
+
+=over 4
+
+=item *
+
+First, doing an arithmetical or bitwise operation on a scalar is
+just about the fastest thing you can do in Perl: C<use constant> actually
+creates a subroutine call, and array and hash lookups are much slower. Is
+this over-optimization at the expense of readability? Possibly, but the
+debugger accesses these variables a I<lot>. Any rewrite of the code will
+probably have to benchmark alternate implementations and see which is the
+best balance of readability and speed, and then document how it actually
+works.
+
+=item *
+
+Second, it's very easy to serialize a scalar number. This is done in
+the restart code; the debugger state variables are saved in C<%ENV> and then
+restored when the debugger is restarted. Having them be just numbers makes
+this trivial.
+
+=item *
+
+Third, some of these variables are being shared with the Perl core
+smack in the middle of the interpreter's execution loop. It's much faster for
+a C program (like the interpreter) to check a bit in a scalar than to access
+several different variables (or a Perl array).
+
+=back
+
+=head2 What are those C<XXX> comments for?
+
+Any comment containing C<XXX> means that the comment is either somewhat
+speculative - it's not exactly clear what a given variable or chunk of
+code is doing, or that it is incomplete - the basics may be clear, but the
+subtleties are not completely documented.
+
+Send in a patch if you can clear up, fill out, or clarify an C<XXX>.
+
+=head1 DATA STRUCTURES MAINTAINED BY CORE
+
+There are a number of special data structures provided to the debugger by
+the Perl interpreter.
+
+The array C<@{$main::{'_<'.$filename}}> (aliased locally to C<@dbline>
+via glob assignment) contains the text from C<$filename>, with each
+element corresponding to a single line of C<$filename>. Additionally,
+breakable lines will be dualvars with the numeric component being the
+memory address of a COP node. Non-breakable lines are dualvar to 0.
+
+The hash C<%{'_<'.$filename}> (aliased locally to C<%dbline> via glob
+assignment) contains breakpoints and actions. The keys are line numbers;
+you can set individual values, but not the whole hash. The Perl interpreter
+uses this hash to determine where breakpoints have been set. Any true value is
+considered to be a breakpoint; C<perl5db.pl> uses C<$break_condition\0$action>.
+Values are magical in numeric context: 1 if the line is breakable, 0 if not.
+
+The scalar C<${"_<$filename"}> simply contains the string C<$filename>.
+This is also the case for evaluated strings that contain subroutines, or
+which are currently being executed. The $filename for C<eval>ed strings looks
+like C<(eval 34).
+
+=head1 DEBUGGER STARTUP
+
+When C<perl5db.pl> starts, it reads an rcfile (C<perl5db.ini> for
+non-interactive sessions, C<.perldb> for interactive ones) that can set a number
+of options. In addition, this file may define a subroutine C<&afterinit>
+that will be executed (in the debugger's context) after the debugger has
+initialized itself.
+
+Next, it checks the C<PERLDB_OPTS> environment variable and treats its
+contents as the argument of a C<o> command in the debugger.
+
+=head2 STARTUP-ONLY OPTIONS
+
+The following options can only be specified at startup.
+To set them in your rcfile, add a call to
+C<&parse_options("optionName=new_value")>.
+
+=over 4
+
+=item * TTY
+
+the TTY to use for debugging i/o.
+
+=item * noTTY
+
+if set, goes in NonStop mode. On interrupt, if TTY is not set,
+uses the value of noTTY or F<$HOME/.perldbtty$$> to find TTY using
+Term::Rendezvous. Current variant is to have the name of TTY in this
+file.
+
+=item * ReadLine
+
+if false, a dummy ReadLine is used, so you can debug
+ReadLine applications.
+
+=item * NonStop
+
+if true, no i/o is performed until interrupt.
+
+=item * LineInfo
+
+file or pipe to print line number info to. If it is a
+pipe, a short "emacs like" message is used.
+
+=item * RemotePort
+
+host:port to connect to on remote host for remote debugging.
+
+=item * HistFile
+
+file to store session history to. There is no default and so no
+history file is written unless this variable is explicitly set.
+
+=item * HistSize
+
+number of commands to store to the file specified in C<HistFile>.
+Default is 100.
+
+=back
+
+=head3 SAMPLE RCFILE
+
+ &parse_options("NonStop=1 LineInfo=db.out");
+ sub afterinit { $trace = 1; }
+
+The script will run without human intervention, putting trace
+information into C<db.out>. (If you interrupt it, you had better
+reset C<LineInfo> to something I<interactive>!)
+
+=head1 INTERNALS DESCRIPTION
+
+=head2 DEBUGGER INTERFACE VARIABLES
+
+Perl supplies the values for C<%sub>. It effectively inserts
+a C<&DB::DB();> in front of each place that can have a
+breakpoint. At each subroutine call, it calls C<&DB::sub> with
+C<$DB::sub> set to the called subroutine. It also inserts a C<BEGIN
+{require 'perl5db.pl'}> before the first line.
+
+After each C<require>d file is compiled, but before it is executed, a
+call to C<&DB::postponed($main::{'_<'.$filename})> is done. C<$filename>
+is the expanded name of the C<require>d file (as found via C<%INC>).
+
+=head3 IMPORTANT INTERNAL VARIABLES
+
+=head4 C<$CreateTTY>
+
+Used to control when the debugger will attempt to acquire another TTY to be
+used for input.
+
+=over
+
+=item * 1 - on C<fork()>
+
+=item * 2 - debugger is started inside debugger
+
+=item * 4 - on startup
+
+=back
+
+=head4 C<$doret>
+
+The value -2 indicates that no return value should be printed.
+Any other positive value causes C<DB::sub> to print return values.
+
+=head4 C<$evalarg>
+
+The item to be eval'ed by C<DB::eval>. Used to prevent messing with the current
+contents of C<@_> when C<DB::eval> is called.
+
+=head4 C<$frame>
+
+Determines what messages (if any) will get printed when a subroutine (or eval)
+is entered or exited.
+
+=over 4
+
+=item * 0 - No enter/exit messages
+
+=item * 1 - Print I<entering> messages on subroutine entry
+
+=item * 2 - Adds exit messages on subroutine exit. If no other flag is on, acts like 1+2.
+
+=item * 4 - Extended messages: C<< <in|out> I<context>=I<fully-qualified sub name> from I<file>:I<line> >>. If no other flag is on, acts like 1+4.
+
+=item * 8 - Adds parameter information to messages, and overloaded stringify and tied FETCH is enabled on the printed arguments. Ignored if C<4> is not on.
+
+=item * 16 - Adds C<I<context> return from I<subname>: I<value>> messages on subroutine/eval exit. Ignored if C<4> is is not on.
+
+=back
+
+To get everything, use C<$frame=30> (or C<o f=30> as a debugger command).
+The debugger internally juggles the value of C<$frame> during execution to
+protect external modules that the debugger uses from getting traced.
+
+=head4 C<$level>
+
+Tracks current debugger nesting level. Used to figure out how many
+C<E<lt>E<gt>> pairs to surround the line number with when the debugger
+outputs a prompt. Also used to help determine if the program has finished
+during command parsing.
+
+=head4 C<$onetimeDump>
+
+Controls what (if anything) C<DB::eval()> will print after evaluating an
+expression.
+
+=over 4
+
+=item * C<undef> - don't print anything
+
+=item * C<dump> - use C<dumpvar.pl> to display the value returned
+
+=item * C<methods> - print the methods callable on the first item returned
+
+=back
+
+=head4 C<$onetimeDumpDepth>
+
+Controls how far down C<dumpvar.pl> will go before printing C<...> while
+dumping a structure. Numeric. If C<undef>, print all levels.
+
+=head4 C<$signal>
+
+Used to track whether or not an C<INT> signal has been detected. C<DB::DB()>,
+which is called before every statement, checks this and puts the user into
+command mode if it finds C<$signal> set to a true value.
+
+=head4 C<$single>
+
+Controls behavior during single-stepping. Stacked in C<@stack> on entry to
+each subroutine; popped again at the end of each subroutine.
+
+=over 4
+
+=item * 0 - run continuously.
+
+=item * 1 - single-step, go into subs. The C<s> command.
+
+=item * 2 - single-step, don't go into subs. The C<n> command.
+
+=item * 4 - print current sub depth (turned on to force this when C<too much
+recursion> occurs.
+
+=back
+
+=head4 C<$trace>
+
+Controls the output of trace information.
+
+=over 4
+
+=item * 1 - The C<t> command was entered to turn on tracing (every line executed is printed)
+
+=item * 2 - watch expressions are active
+
+=item * 4 - user defined a C<watchfunction()> in C<afterinit()>
+
+=back
+
+=head4 C<$slave_editor>
+
+1 if C<LINEINFO> was directed to a pipe; 0 otherwise.
+
+=head4 C<@cmdfhs>
+
+Stack of filehandles that C<DB::readline()> will read commands from.
+Manipulated by the debugger's C<source> command and C<DB::readline()> itself.
+
+=head4 C<@dbline>
+
+Local alias to the magical line array, C<@{$main::{'_<'.$filename}}> ,
+supplied by the Perl interpreter to the debugger. Contains the source.
+
+=head4 C<@old_watch>
+
+Previous values of watch expressions. First set when the expression is
+entered; reset whenever the watch expression changes.
+
+=head4 C<@saved>
+
+Saves important globals (C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>, C<$\>, C<$^W>)
+so that the debugger can substitute safe values while it's running, and
+restore them when it returns control.
+
+=head4 C<@stack>
+
+Saves the current value of C<$single> on entry to a subroutine.
+Manipulated by the C<c> command to turn off tracing in all subs above the
+current one.
+
+=head4 C<@to_watch>
+
+The 'watch' expressions: to be evaluated before each line is executed.
+
+=head4 C<@typeahead>
+
+The typeahead buffer, used by C<DB::readline>.
+
+=head4 C<%alias>
+
+Command aliases. Stored as character strings to be substituted for a command
+entered.
+
+=head4 C<%break_on_load>
+
+Keys are file names, values are 1 (break when this file is loaded) or undef
+(don't break when it is loaded).
+
+=head4 C<%dbline>
+
+Keys are line numbers, values are C<condition\0action>. If used in numeric
+context, values are 0 if not breakable, 1 if breakable, no matter what is
+in the actual hash entry.
+
+=head4 C<%had_breakpoints>
+
+Keys are file names; values are bitfields:
+
+=over 4
+
+=item * 1 - file has a breakpoint in it.
+
+=item * 2 - file has an action in it.
+
+=back
+
+A zero or undefined value means this file has neither.
+
+=head4 C<%option>
+
+Stores the debugger options. These are character string values.
+
+=head4 C<%postponed>
+
+Saves breakpoints for code that hasn't been compiled yet.
+Keys are subroutine names, values are:
+
+=over 4
+
+=item * C<compile> - break when this sub is compiled
+
+=item * C<< break +0 if <condition> >> - break (conditionally) at the start of this routine. The condition will be '1' if no condition was specified.
+
+=back
+
+=head4 C<%postponed_file>
+
+This hash keeps track of breakpoints that need to be set for files that have
+not yet been compiled. Keys are filenames; values are references to hashes.
+Each of these hashes is keyed by line number, and its values are breakpoint
+definitions (C<condition\0action>).
+
+=head1 DEBUGGER INITIALIZATION
+
+The debugger's initialization actually jumps all over the place inside this
+package. This is because there are several BEGIN blocks (which of course
+execute immediately) spread through the code. Why is that?
+
+The debugger needs to be able to change some things and set some things up
+before the debugger code is compiled; most notably, the C<$deep> variable that
+C<DB::sub> uses to tell when a program has recursed deeply. In addition, the
+debugger has to turn off warnings while the debugger code is compiled, but then
+restore them to their original setting before the program being debugged begins
+executing.
+
+The first C<BEGIN> block simply turns off warnings by saving the current
+setting of C<$^W> and then setting it to zero. The second one initializes
+the debugger variables that are needed before the debugger begins executing.
+The third one puts C<$^X> back to its former value.
+
+We'll detail the second C<BEGIN> block later; just remember that if you need
+to initialize something before the debugger starts really executing, that's
+where it has to go.
+
+=cut
+
+package DB;
+
+use strict;
+use dbutil;
+
+BEGIN {eval 'use IO::Handle'}; # Needed for flush only? breaks under miniperl
+
+BEGIN {
+ require feature;
+ $^V =~ /^v(\d+\.\d+)/;
+ feature->import(":$1");
+}
+
+
+# Debugger for Perl 5.00x; perl5db.pl patch level:
+use vars qw($VERSION $header);
+
+$VERSION = 'Speare Pro patch 0.0.1';
+$header = "perl5db.pl version $VERSION";
+
+=head1 DEBUGGER ROUTINES
+
+=head2 C<DB::eval()>
+
+This function replaces straight C<eval()> inside the debugger; it simplifies
+the process of evaluating code in the user's context.
+
+The code to be evaluated is passed via the package global variable
+C<$DB::evalarg>; this is done to avoid fiddling with the contents of C<@_>.
+
+Before we do the C<eval()>, we preserve the current settings of C<$trace>,
+C<$single>, C<$^D> and C<$usercontext>. The latter contains the
+preserved values of C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>, C<$\>, C<$^W> and the
+user's current package, grabbed when C<DB::DB> got control. This causes the
+proper context to be used when the eval is actually done. Afterward, we
+restore C<$trace>, C<$single>, and C<$^D>.
+
+Next we need to handle C<$@> without getting confused. We save C<$@> in a
+local lexical, localize C<$saved[0]> (which is where C<save()> will put
+C<$@>), and then call C<save()> to capture C<$@>, C<$!>, C<$^E>, C<$,>,
+C<$/>, C<$\>, and C<$^W>) and set C<$,>, C<$/>, C<$\>, and C<$^W> to values
+considered sane by the debugger. If there was an C<eval()> error, we print
+it on the debugger's output. If C<$onetimedump> is defined, we call
+C<dumpit> if it's set to 'dump', or C<methods> if it's set to
+'methods'. Setting it to something else causes the debugger to do the eval
+but not print the result - handy if you want to do something else with it
+(the "watch expressions" code does this to get the value of the watch
+expression but not show it unless it matters).
+
+In any case, we then return the list of output from C<eval> to the caller,
+and unwinding restores the former version of C<$@> in C<@saved> as well
+(the localization of C<$saved[0]> goes away at the end of this scope).
+
+=head3 Parameters and variables influencing execution of DB::eval()
+
+C<DB::eval> isn't parameterized in the standard way; this is to keep the
+debugger's calls to C<DB::eval()> from mucking with C<@_>, among other things.
+The variables listed below influence C<DB::eval()>'s execution directly.
+
+=over 4
+
+=item C<$evalarg> - the thing to actually be eval'ed
+
+=item C<$trace> - Current state of execution tracing
+
+=item C<$single> - Current state of single-stepping
+
+=item C<$onetimeDump> - what is to be displayed after the evaluation
+
+=item C<$onetimeDumpDepth> - how deep C<dumpit()> should go when dumping results
+
+=back
+
+The following variables are altered by C<DB::eval()> during its execution. They
+are "stacked" via C<local()>, enabling recursive calls to C<DB::eval()>.
+
+=over 4
+
+=item C<@res> - used to capture output from actual C<eval>.
+
+=item C<$otrace> - saved value of C<$trace>.
+
+=item C<$osingle> - saved value of C<$single>.
+
+=item C<$od> - saved value of C<$^D>.
+
+=item C<$saved[0]> - saved value of C<$@>.
+
+=item $\ - for output of C<$@> if there is an evaluation error.
+
+=back
+
+=head3 The problem of lexicals
+
+The context of C<DB::eval()> presents us with some problems. Obviously,
+we want to be 'sandboxed' away from the debugger's internals when we do
+the eval, but we need some way to control how punctuation variables and
+debugger globals are used.
+
+We can't use local, because the code inside C<DB::eval> can see localized
+variables; and we can't use C<my> either for the same reason. The code
+in this routine compromises and uses C<my>.
+
+After this routine is over, we don't have user code executing in the debugger's
+context, so we can use C<my> freely.
+
+=cut
+
+############################################## Begin lexical danger zone
+
+# 'my' variables used here could leak into (that is, be visible in)
+# the context that the code being evaluated is executing in. This means that
+# the code could modify the debugger's variables.
+#
+# Fiddling with the debugger's context could be Bad. We insulate things as
+# much as we can.
+
+use vars qw(
+ @args
+ %break_on_load
+ $CommandSet
+ $CreateTTY
+ $DBGR
+ @dbline
+ $dbline
+ %dbline
+ $dieLevel
+ $filename
+ $histfile
+ $histsize
+ $IN
+ $inhibit_exit
+ @ini_INC
+ $ini_warn
+ $maxtrace
+ $od
+ @options
+ $osingle
+ $otrace
+ $pager
+ $post
+ %postponed
+ $prc
+ $pre
+ $pretype
+ $psh
+ @RememberOnROptions
+ $remoteport
+ @res
+ $rl
+ @saved
+ $signalLevel
+ $sub
+ $term
+ $usercontext
+ $warnLevel
+);
+
+our (
+ @cmdfhs,
+ $evalarg,
+ $frame,
+ $hist,
+ $ImmediateStop,
+ $line,
+ $onetimeDump,
+ $onetimedumpDepth,
+ %option,
+ $OUT,
+ $packname,
+ $signal,
+ $single,
+ $start,
+ %sub,
+ $subname,
+ $trace,
+ $window
+);
+
+# Used to save @ARGV and extract any debugger-related flags.
+use vars qw(@ARGS);
+
+# Used to prevent multiple entries to diesignal()
+# (if for instance diesignal() itself dies)
+use vars qw($panic);
+
+# Used to prevent the debugger from running nonstop
+# after a restart
+our ($second_time);
+
+sub _calc_usercontext {
+ my ($package) = @_;
+
+ # Cancel strict completely for the evaluated code, so the code
+ # the user evaluates won't be affected by it. (Shlomi Fish)
+ return 'no strict; ($@, $!, $^E, $,, $/, $\, $^W) = @DB::saved;'
+ . "package $package;"; # this won't let them modify, alas
+}
+
+sub eval {
+
+ # 'my' would make it visible from user code
+ # but so does local! --tchrist
+ # Remember: this localizes @DB::res, not @main::res.
+ local @res;
+ {
+
+ # Try to keep the user code from messing with us. Save these so that
+ # even if the eval'ed code changes them, we can put them back again.
+ # Needed because the user could refer directly to the debugger's
+ # package globals (and any 'my' variables in this containing scope)
+ # inside the eval(), and we want to try to stay safe.
+ local $otrace = $trace;
+ local $osingle = $single;
+ local $od = $^D;
+
+ # Untaint the incoming eval() argument.
+ { ($evalarg) = $evalarg =~ /(.*)/s; }
+
+ # $usercontext built in DB::DB near the comment
+ # "set up the context for DB::eval ..."
+ # Evaluate and save any results.
+ @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
+
+ # Restore those old values.
+ $trace = $otrace;
+ $single = $osingle;
+ $^D = $od;
+ }
+
+ # Save the current value of $@, and preserve it in the debugger's copy
+ # of the saved precious globals.
+ my $at = $@;
+
+ # Since we're only saving $@, we only have to localize the array element
+ # that it will be stored in.
+ local $saved[0]; # Preserve the old value of $@
+ eval { &DB::save };
+
+ # Now see whether we need to report an error back to the user.
+ if ($at) {
+ local $\ = '';
+ print "\r\n";
+ print $OUT $at;
+ # print $OUT '\r\n{"command": "error", "msg": "$at"}\r\n';
+ print "\r\n";
+ }
+
+ # Display as required by the caller. $onetimeDump and $onetimedumpDepth
+ # are package globals.
+ elsif ($onetimeDump) {
+ if ( $onetimeDump eq 'dump' ) {
+ local $option{dumpDepth} = $onetimedumpDepth
+ if defined $onetimedumpDepth;
+ dumpit( $OUT, \@res );
+ }
+ elsif ( $onetimeDump eq 'methods' ) {
+ methods( $res[0] );
+ }
+ } ## end elsif ($onetimeDump)
+ @res;
+} ## end sub eval
+
+############################################## End lexical danger zone
+
+# After this point it is safe to introduce lexicals.
+# The code being debugged will be executing in its own context, and
+# can't see the inside of the debugger.
+#
+# However, one should not overdo it: leave as much control from outside as
+# possible. If you make something a lexical, it's not going to be addressable
+# from outside the debugger even if you know its name.
+
+# This file is automatically included if you do perl -d.
+# It's probably not useful to include this yourself.
+#
+# Before venturing further into these twisty passages, it is
+# wise to read the perldebguts man page or risk the ire of dragons.
+#
+# (It should be noted that perldebguts will tell you a lot about
+# the underlying mechanics of how the debugger interfaces into the
+# Perl interpreter, but not a lot about the debugger itself. The new
+# comments in this code try to address this problem.)
+
+# Note that no subroutine call is possible until &DB::sub is defined
+# (for subroutines defined outside of the package DB). In fact the same is
+# true if $deep is not defined.
+
+# Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
+
+# modified Perl debugger, to be run from Emacs in perldb-mode
+# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
+# Johan Vromans -- upgrade to 4.0 pl 10
+# Ilya Zakharevich -- patches after 5.001 (and some before ;-)
+########################################################################
+
+=head1 DEBUGGER INITIALIZATION
+
+The debugger starts up in phases.
+
+=head2 BASIC SETUP
+
+First, it initializes the environment it wants to run in: turning off
+warnings during its own compilation, defining variables which it will need
+to avoid warnings later, setting itself up to not exit when the program
+terminates, and defaulting to printing return values for the C<r> command.
+
+=cut
+
+# Needed for the statement after exec():
+#
+# This BEGIN block is simply used to switch off warnings during debugger
+# compilation. Probably it would be better practice to fix the warnings,
+# but this is how it's done at the moment.
+
+BEGIN {
+ $ini_warn = $^W;
+ $^W = 0;
+} # Switch compilation warnings off until another BEGIN.
+
+local ($^W) = 0; # Switch run-time warnings off during init.
+
+=head2 THREADS SUPPORT
+
+If we are running under a threaded Perl, we require threads and threads::shared
+if the environment variable C<PERL5DB_THREADED> is set, to enable proper
+threaded debugger control. C<-dt> can also be used to set this.
+
+Each new thread will be announced and the debugger prompt will always inform
+you of each new thread created. It will also indicate the thread id in which
+we are currently running within the prompt like this:
+
+ [tid] DB<$i>
+
+Where C<[tid]> is an integer thread id and C<$i> is the familiar debugger
+command prompt. The prompt will show: C<[0]> when running under threads, but
+not actually in a thread. C<[tid]> is consistent with C<gdb> usage.
+
+While running under threads, when you set or delete a breakpoint (etc.), this
+will apply to all threads, not just the currently running one. When you are
+in a currently executing thread, you will stay there until it completes. With
+the current implementation it is not currently possible to hop from one thread
+to another.
+
+The C<e> and C<E> commands are currently fairly minimal - see C<h e> and C<h E>.
+
+Note that threading support was built into the debugger as of Perl version
+C<5.8.6> and debugger version C<1.2.8>.
+
+=cut
+
+BEGIN {
+ # ensure we can share our non-threaded variables or no-op
+ if ($ENV{PERL5DB_THREADED}) {
+ require threads;
+ require threads::shared;
+ import threads::shared qw(share);
+ $DBGR;
+ share(\$DBGR);
+ lock($DBGR);
+ print "Threads support enabled\n";
+ } else {
+ *share = sub(\[$@%]) {};
+ }
+}
+
+# These variables control the execution of 'dumpvar.pl'.
+{
+ package dumpvar;
+ use vars qw(
+ $hashDepth
+ $arrayDepth
+ $dumpDBFiles
+ $dumpPackages
+ $quoteHighBit
+ $printUndef
+ $globPrint
+ $usageOnly
+ );
+}
+
+# used to control die() reporting in diesignal()
+{
+ package Carp;
+ use vars qw($CarpLevel);
+}
+
+# without threads, $filename is not defined until DB::DB is called
+share($main::{'_<'.$filename}) if defined $filename;
+
+# Command-line + PERLLIB:
+# Save the contents of @INC before they are modified elsewhere.
+@ini_INC = @INC;
+
+# This was an attempt to clear out the previous values of various
+# trapped errors. Apparently it didn't help. XXX More info needed!
+# $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
+
+# We set these variables to safe values. We don't want to blindly turn
+# off warnings, because other packages may still want them.
+$trace = $signal = $single = 0; # Uninitialized warning suppression
+ # (local $^W cannot help - other packages!).
+
+# Default to not exiting when program finishes; print the return
+# value when the 'r' command is used to return from a subroutine.
+$inhibit_exit = $option{PrintRet} = 1;
+
+use vars qw($trace_to_depth);
+
+# Default to 1E9 so it won't be limited to a certain recursion depth.
+$trace_to_depth = 1E9;
+
+=head1 OPTION PROCESSING
+
+The debugger's options are actually spread out over the debugger itself and
+C<dumpvar.pl>; some of these are variables to be set, while others are
+subs to be called with a value. To try to make this a little easier to
+manage, the debugger uses a few data structures to define what options
+are legal and how they are to be processed.
+
+First, the C<@options> array defines the I<names> of all the options that
+are to be accepted.
+
+=cut
+
+@options = qw(
+ CommandSet HistFile HistSize
+ hashDepth arrayDepth dumpDepth
+ DumpDBFiles DumpPackages DumpReused
+ compactDump veryCompact quote
+ HighBit undefPrint globPrint
+ PrintRet UsageOnly frame
+ AutoTrace TTY noTTY
+ ReadLine NonStop LineInfo
+ maxTraceLen recallCommand ShellBang
+ pager tkRunning ornaments
+ signalLevel warnLevel dieLevel
+ inhibit_exit ImmediateStop bareStringify
+ CreateTTY RemotePort windowSize
+ DollarCaretP
+);
+
+@RememberOnROptions = qw(DollarCaretP);
+
+=pod
+
+Second, C<optionVars> lists the variables that each option uses to save its
+state.
+
+=cut
+
+use vars qw(%optionVars);
+
+%optionVars = (
+ hashDepth => \$dumpvar::hashDepth,
+ arrayDepth => \$dumpvar::arrayDepth,
+ CommandSet => \$CommandSet,
+ DumpDBFiles => \$dumpvar::dumpDBFiles,
+ DumpPackages => \$dumpvar::dumpPackages,
+ DumpReused => \$dumpvar::dumpReused,
+ HighBit => \$dumpvar::quoteHighBit,
+ undefPrint => \$dumpvar::printUndef,
+ globPrint => \$dumpvar::globPrint,
+ UsageOnly => \$dumpvar::usageOnly,
+ CreateTTY => \$CreateTTY,
+ bareStringify => \$dumpvar::bareStringify,
+ frame => \$frame,
+ AutoTrace => \$trace,
+ inhibit_exit => \$inhibit_exit,
+ maxTraceLen => \$maxtrace,
+ ImmediateStop => \$ImmediateStop,
+ RemotePort => \$remoteport,
+ windowSize => \$window,
+ HistFile => \$histfile,
+ HistSize => \$histsize,
+);
+
+=pod
+
+Third, C<%optionAction> defines the subroutine to be called to process each
+option.
+
+=cut
+
+use vars qw(%optionAction);
+
+%optionAction = (
+ compactDump => \&dumpvar::compactDump,
+ veryCompact => \&dumpvar::veryCompact,
+ quote => \&dumpvar::quote,
+ TTY => \&TTY,
+ noTTY => \&noTTY,
+ ReadLine => \&ReadLine,
+ NonStop => \&NonStop,
+ LineInfo => \&LineInfo,
+ recallCommand => \&recallCommand,
+ ShellBang => \&shellBang,
+ pager => \&pager,
+ signalLevel => \&signalLevel,
+ warnLevel => \&warnLevel,
+ dieLevel => \&dieLevel,
+ tkRunning => \&tkRunning,
+ ornaments => \&ornaments,
+ RemotePort => \&RemotePort,
+ DollarCaretP => \&DollarCaretP,
+);
+
+=pod
+
+Last, the C<%optionRequire> notes modules that must be C<require>d if an
+option is used.
+
+=cut
+
+# Note that this list is not complete: several options not listed here
+# actually require that dumpvar.pl be loaded for them to work, but are
+# not in the table. A subsequent patch will correct this problem; for
+# the moment, we're just recommenting, and we are NOT going to change
+# function.
+use vars qw(%optionRequire);
+
+%optionRequire = (
+ compactDump => 'dumpvar.pl',
+ veryCompact => 'dumpvar.pl',
+ quote => 'dumpvar.pl',
+);
+
+=pod
+
+There are a number of initialization-related variables which can be set
+by putting code to set them in a BEGIN block in the C<PERL5DB> environment
+variable. These are:
+
+=over 4
+
+=item C<$rl> - readline control XXX needs more explanation
+
+=item C<$warnLevel> - whether or not debugger takes over warning handling
+
+=item C<$dieLevel> - whether or not debugger takes over die handling
+
+=item C<$signalLevel> - whether or not debugger takes over signal handling
+
+=item C<$pre> - preprompt actions (array reference)
+
+=item C<$post> - postprompt actions (array reference)
+
+=item C<$pretype>
+
+=item C<$CreateTTY> - whether or not to create a new TTY for this debugger
+
+=item C<$CommandSet> - which command set to use (defaults to new, documented set)
+
+=back
+
+=cut
+
+# These guys may be defined in $ENV{PERL5DB} :
+$rl = 1 unless defined $rl;
+$warnLevel = 1 unless defined $warnLevel;
+$dieLevel = 1 unless defined $dieLevel;
+$signalLevel = 1 unless defined $signalLevel;
+$pre = [] unless defined $pre;
+$post = [] unless defined $post;
+$pretype = [] unless defined $pretype;
+$CreateTTY = 3 unless defined $CreateTTY;
+$CommandSet = '580' unless defined $CommandSet;
+
+share($rl);
+share($warnLevel);
+share($dieLevel);
+share($signalLevel);
+share($pre);
+share($post);
+share($pretype);
+share($rl);
+share($CreateTTY);
+share($CommandSet);
+
+=pod
+
+The default C<die>, C<warn>, and C<signal> handlers are set up.
+
+=cut
+
+warnLevel($warnLevel);
+dieLevel($dieLevel);
+signalLevel($signalLevel);
+
+=pod
+
+The pager to be used is needed next. We try to get it from the
+environment first. If it's not defined there, we try to find it in
+the Perl C<Config.pm>. If it's not there, we default to C<more>. We
+then call the C<pager()> function to save the pager name.
+
+=cut
+
+# This routine makes sure $pager is set up so that '|' can use it.
+pager(
+
+ # If PAGER is defined in the environment, use it.
+ defined $ENV{PAGER}
+ ? $ENV{PAGER}
+
+ # If not, see if Config.pm defines it.
+ : eval { require Config }
+ && defined $Config::Config{pager}
+ ? $Config::Config{pager}
+
+ # If not, fall back to 'more'.
+ : 'more'
+ )
+ unless defined $pager;
+
+=pod
+
+We set up the command to be used to access the man pages, the command
+recall character (C<!> unless otherwise defined) and the shell escape
+character (C<!> unless otherwise defined). Yes, these do conflict, and
+neither works in the debugger at the moment.
+
+=cut
+
+setman();
+
+# Set up defaults for command recall and shell escape (note:
+# these currently don't work in linemode debugging).
+recallCommand("!") unless defined $prc;
+shellBang("!") unless defined $psh;
+
+=pod
+
+We then set up the gigantic string containing the debugger help.
+We also set the limit on the number of arguments we'll display during a
+trace.
+
+=cut
+
+sethelp();
+
+# If we didn't get a default for the length of eval/stack trace args,
+# set it here.
+$maxtrace = 400 unless defined $maxtrace;
+
+=head2 SETTING UP THE DEBUGGER GREETING
+
+The debugger I<greeting> helps to inform the user how many debuggers are
+running, and whether the current debugger is the primary or a child.
+
+If we are the primary, we just hang onto our pid so we'll have it when
+or if we start a child debugger. If we are a child, we'll set things up
+so we'll have a unique greeting and so the parent will give us our own
+TTY later.
+
+We save the current contents of the C<PERLDB_PIDS> environment variable
+because we mess around with it. We'll also need to hang onto it because
+we'll need it if we restart.
+
+Child debuggers make a label out of the current PID structure recorded in
+PERLDB_PIDS plus the new PID. They also mark themselves as not having a TTY
+yet so the parent will give them one later via C<resetterm()>.
+
+=cut
+
+# Save the current contents of the environment; we're about to
+# much with it. We'll need this if we have to restart.
+use vars qw($ini_pids);
+$ini_pids = $ENV{PERLDB_PIDS};
+
+use vars qw ($pids $term_pid);
+
+if ( defined $ENV{PERLDB_PIDS} ) {
+
+ # We're a child. Make us a label out of the current PID structure
+ # recorded in PERLDB_PIDS plus our (new) PID. Mark us as not having
+ # a term yet so the parent will give us one later via resetterm().
+
+ my $env_pids = $ENV{PERLDB_PIDS};
+ $pids = "[$env_pids]";
+
+ # Unless we are on OpenVMS, all programs under the DCL shell run under
+ # the same PID.
+
+ if (($^O eq 'VMS') && ($env_pids =~ /\b$$\b/)) {
+ $term_pid = $$;
+ }
+ else {
+ $ENV{PERLDB_PIDS} .= "->$$";
+ $term_pid = -1;
+ }
+
+} ## end if (defined $ENV{PERLDB_PIDS...
+else {
+
+ # We're the parent PID. Initialize PERLDB_PID in case we end up with a
+ # child debugger, and mark us as the parent, so we'll know to set up
+ # more TTY's is we have to.
+ $ENV{PERLDB_PIDS} = "$$";
+ $pids = "[pid=$$]";
+ $term_pid = $$;
+}
+
+use vars qw($pidprompt);
+$pidprompt = '';
+
+# Sets up $emacs as a synonym for $slave_editor.
+our ($slave_editor);
+*emacs = $slave_editor if $slave_editor; # May be used in afterinit()...
+
+=head2 READING THE RC FILE
+
+The debugger will read a file of initialization options if supplied. If
+running interactively, this is C<.perldb>; if not, it's C<perldb.ini>.
+
+=cut
+
+# As noted, this test really doesn't check accurately that the debugger
+# is running at a terminal or not.
+
+use vars qw($rcfile);
+{
+ my $dev_tty = (($^O eq 'VMS') ? 'TT:' : '/dev/tty');
+ # this is the wrong metric!
+ $rcfile = ((-e $dev_tty) ? ".perldb" : "perldb.ini");
+}
+
+=pod
+
+The debugger does a safety test of the file to be read. It must be owned
+either by the current user or root, and must only be writable by the owner.
+
+=cut
+
+# This wraps a safety test around "do" to read and evaluate the init file.
+#
+# This isn't really safe, because there's a race
+# between checking and opening. The solution is to
+# open and fstat the handle, but then you have to read and
+# eval the contents. But then the silly thing gets
+# your lexical scope, which is unfortunate at best.
+sub safe_do {
+ my $file = shift;
+
+ # Just exactly what part of the word "CORE::" don't you understand?
+ local $SIG{__WARN__};
+ local $SIG{__DIE__};
+
+ unless ( is_safe_file($file) ) {
+ CORE::warn <<EO_GRIPE;
+perldb: Must not source insecure rcfile $file.
+ You or the superuser must be the owner, and it must not
+ be writable by anyone but its owner.
+EO_GRIPE
+ return;
+ } ## end unless (is_safe_file($file...
+
+ do $file;
+ CORE::warn("perldb: couldn't parse $file: $@") if $@;
+} ## end sub safe_do
+
+# This is the safety test itself.
+#
+# Verifies that owner is either real user or superuser and that no
+# one but owner may write to it. This function is of limited use
+# when called on a path instead of upon a handle, because there are
+# no guarantees that filename (by dirent) whose file (by ino) is
+# eventually accessed is the same as the one tested.
+# Assumes that the file's existence is not in doubt.
+sub is_safe_file {
+ my $path = shift;
+ stat($path) || return; # mysteriously vaporized
+ my ( $dev, $ino, $mode, $nlink, $uid, $gid ) = stat(_);
+
+ return 0 if $uid != 0 && $uid != $<;
+ return 0 if $mode & 022;
+ return 1;
+} ## end sub is_safe_file
+
+# If the rcfile (whichever one we decided was the right one to read)
+# exists, we safely do it.
+if ( -f $rcfile ) {
+ safe_do("./$rcfile");
+}
+
+# If there isn't one here, try the user's home directory.
+elsif ( defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile" ) {
+ safe_do("$ENV{HOME}/$rcfile");
+}
+
+# Else try the login directory.
+elsif ( defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile" ) {
+ safe_do("$ENV{LOGDIR}/$rcfile");
+}
+
+# If the PERLDB_OPTS variable has options in it, parse those out next.
+if ( defined $ENV{PERLDB_OPTS} ) {
+ parse_options( $ENV{PERLDB_OPTS} );
+}
+
+=pod
+
+The last thing we do during initialization is determine which subroutine is
+to be used to obtain a new terminal when a new debugger is started. Right now,
+the debugger only handles TCP sockets, X11, OS/2, amd Mac OS X
+(darwin).
+
+=cut
+
+# Set up the get_fork_TTY subroutine to be aliased to the proper routine.
+# Works if you're running an xterm or xterm-like window, or you're on
+# OS/2, or on Mac OS X. This may need some expansion.
+
+if (not defined &get_fork_TTY) # only if no routine exists
+{
+ if ( defined $remoteport ) {
+ # Expect an inetd-like server
+ *get_fork_TTY = \&socket_get_fork_TTY; # to listen to us
+ }
+ elsif (defined $ENV{TERM} # If we know what kind
+ # of terminal this is,
+ and $ENV{TERM} eq 'xterm' # and it's an xterm,
+ and defined $ENV{DISPLAY} # and what display it's on,
+ )
+ {
+ *get_fork_TTY = \&xterm_get_fork_TTY; # use the xterm version
+ }
+ elsif ( $^O eq 'os2' ) { # If this is OS/2,
+ *get_fork_TTY = \&os2_get_fork_TTY; # use the OS/2 version
+ }
+ elsif ( $^O eq 'darwin' # If this is Mac OS X
+ and defined $ENV{TERM_PROGRAM} # and we're running inside
+ and $ENV{TERM_PROGRAM}
+ eq 'Apple_Terminal' # Terminal.app
+ )
+ {
+ *get_fork_TTY = \&macosx_get_fork_TTY; # use the Mac OS X version
+ }
+} ## end if (not defined &get_fork_TTY...
+
+# untaint $^O, which may have been tainted by the last statement.
+# see bug [perl #24674]
+$^O =~ m/^(.*)\z/;
+$^O = $1;
+
+# Here begin the unreadable code. It needs fixing.
+
+=head2 RESTART PROCESSING
+
+This section handles the restart command. When the C<R> command is invoked, it
+tries to capture all of the state it can into environment variables, and
+then sets C<PERLDB_RESTART>. When we start executing again, we check to see
+if C<PERLDB_RESTART> is there; if so, we reload all the information that
+the R command stuffed into the environment variables.
+
+ PERLDB_RESTART - flag only, contains no restart data itself.
+ PERLDB_HIST - command history, if it's available
+ PERLDB_ON_LOAD - breakpoints set by the rc file
+ PERLDB_POSTPONE - subs that have been loaded/not executed, and have actions
+ PERLDB_VISITED - files that had breakpoints
+ PERLDB_FILE_... - breakpoints for a file
+ PERLDB_OPT - active options
+ PERLDB_INC - the original @INC
+ PERLDB_PRETYPE - preprompt debugger actions
+ PERLDB_PRE - preprompt Perl code
+ PERLDB_POST - post-prompt Perl code
+ PERLDB_TYPEAHEAD - typeahead captured by readline()
+
+We chug through all these variables and plug the values saved in them
+back into the appropriate spots in the debugger.
+
+=cut
+
+use vars qw(%postponed_file @typeahead);
+
+our (@hist, @truehist);
+
+sub _restore_shared_globals_after_restart
+{
+ @hist = get_list('PERLDB_HIST');
+ %break_on_load = get_list("PERLDB_ON_LOAD");
+ %postponed = get_list("PERLDB_POSTPONE");
+
+ share(@hist);
+ share(@truehist);
+ share(%break_on_load);
+ share(%postponed);
+}
+
+sub _restore_breakpoints_and_actions {
+
+ my @had_breakpoints = get_list("PERLDB_VISITED");
+
+ for my $file_idx ( 0 .. $#had_breakpoints ) {
+ my $filename = $had_breakpoints[$file_idx];
+ my %pf = get_list("PERLDB_FILE_$file_idx");
+ $postponed_file{ $filename } = \%pf if %pf;
+ my @lines = sort {$a <=> $b} keys(%pf);
+ my @enabled_statuses = get_list("PERLDB_FILE_ENABLED_$file_idx");
+ for my $line_idx (0 .. $#lines) {
+ _set_breakpoint_enabled_status(
+ $filename,
+ $lines[$line_idx],
+ ($enabled_statuses[$line_idx] ? 1 : ''),
+ );
+ }
+ }
+
+ return;
+}
+
+sub _restore_options_after_restart
+{
+ my %options_map = get_list("PERLDB_OPT");
+
+ while ( my ( $opt, $val ) = each %options_map ) {
+ $val =~ s/[\\\']/\\$1/g;
+ parse_options("$opt'$val'");
+ }
+
+ return;
+}
+
+sub _restore_globals_after_restart
+{
+ # restore original @INC
+ @INC = get_list("PERLDB_INC");
+ @ini_INC = @INC;
+
+ # return pre/postprompt actions and typeahead buffer
+ $pretype = [ get_list("PERLDB_PRETYPE") ];
+ $pre = [ get_list("PERLDB_PRE") ];
+ $post = [ get_list("PERLDB_POST") ];
+ @typeahead = get_list( "PERLDB_TYPEAHEAD", @typeahead );
+
+ return;
+}
+
+
+if ( exists $ENV{PERLDB_RESTART} ) {
+
+ # We're restarting, so we don't need the flag that says to restart anymore.
+ delete $ENV{PERLDB_RESTART};
+
+ # $restart = 1;
+ _restore_shared_globals_after_restart();
+
+ _restore_breakpoints_and_actions();
+
+ # restore options
+ _restore_options_after_restart();
+
+ _restore_globals_after_restart();
+} ## end if (exists $ENV{PERLDB_RESTART...
+
+=head2 SETTING UP THE TERMINAL
+
+Now, we'll decide how the debugger is going to interact with the user.
+If there's no TTY, we set the debugger to run non-stop; there's not going
+to be anyone there to enter commands.
+
+=cut
+
+use vars qw($notty $console $tty $LINEINFO);
+use vars qw($lineinfo $doccmd);
+
+our ($runnonstop);
+
+# Local autoflush to avoid rt#116769,
+# as calling IO::File methods causes an unresolvable loop
+# that results in debugger failure.
+sub _autoflush {
+ my $o = select($_[0]);
+ $|++;
+ select($o);
+}
+
+if ($notty) {
+ $runnonstop = 1;
+ share($runnonstop);
+}
+
+=pod
+
+If there is a TTY, we have to determine who it belongs to before we can
+proceed. If this is a slave editor or graphical debugger (denoted by
+the first command-line switch being '-emacs'), we shift this off and
+set C<$rl> to 0 (XXX ostensibly to do straight reads).
+
+=cut
+
+else {
+
+ # Is Perl being run from a slave editor or graphical debugger?
+ # If so, don't use readline, and set $slave_editor = 1.
+ if ($slave_editor = ( @main::ARGV && ( $main::ARGV[0] eq '-emacs' ) )) {
+ $rl = 0;
+ shift(@main::ARGV);
+ }
+
+ #require Term::ReadLine;
+
+=pod
+
+We then determine what the console should be on various systems:
+
+=over 4
+
+=item * Cygwin - We use C<stdin> instead of a separate device.
+
+=cut
+
+ if ( $^O eq 'cygwin' ) {
+
+ # /dev/tty is binary. use stdin for textmode
+ undef $console;
+ }
+
+=item * Unix - use F</dev/tty>.
+
+=cut
+
+ elsif ( -e "/dev/tty" ) {
+ $console = "/dev/tty";
+ }
+
+=item * Windows or MSDOS - use C<con>.
+
+=cut
+
+ elsif ( $^O eq 'dos' or -e "con" or $^O eq 'MSWin32' ) {
+ $console = "con";
+ }
+
+=item * VMS - use C<sys$command>.
+
+=cut
+
+ else {
+
+ # everything else is ...
+ $console = "sys\$command";
+ }
+
+=pod
+
+=back
+
+Several other systems don't use a specific console. We C<undef $console>
+for those (Windows using a slave editor/graphical debugger, NetWare, OS/2
+with a slave editor).
+
+=cut
+
+ if ( ( $^O eq 'MSWin32' ) and ( $slave_editor or defined $ENV{EMACS} ) ) {
+
+ # /dev/tty is binary. use stdin for textmode
+ $console = undef;
+ }
+
+ if ( $^O eq 'NetWare' ) {
+
+ # /dev/tty is binary. use stdin for textmode
+ $console = undef;
+ }
+
+ # In OS/2, we need to use STDIN to get textmode too, even though
+ # it pretty much looks like Unix otherwise.
+ if ( defined $ENV{OS2_SHELL} and ( $slave_editor or $ENV{WINDOWID} ) )
+ { # In OS/2
+ $console = undef;
+ }
+
+=pod
+
+If there is a TTY hanging around from a parent, we use that as the console.
+
+=cut
+
+ $console = $tty if defined $tty;
+
+=head2 SOCKET HANDLING
+
+The debugger is capable of opening a socket and carrying out a debugging
+session over the socket.
+
+If C<RemotePort> was defined in the options, the debugger assumes that it
+should try to start a debugging session on that port. It builds the socket
+and then tries to connect the input and output filehandles to it.
+
+=cut
+
+ # Handle socket stuff.
+
+ if ( defined $remoteport ) {
+
+ # If RemotePort was defined in the options, connect input and output
+ # to the socket.
+ $IN = $OUT = connect_remoteport();
+ } ## end if (defined $remoteport)
+
+=pod
+
+If no C<RemotePort> was defined, and we want to create a TTY on startup,
+this is probably a situation where multiple debuggers are running (for example,
+a backticked command that starts up another debugger). We create a new IN and
+OUT filehandle, and do the necessary mojo to create a new TTY if we know how
+and if we can.
+
+=cut
+
+ # Non-socket.
+ else {
+
+ # Two debuggers running (probably a system or a backtick that invokes
+ # the debugger itself under the running one). create a new IN and OUT
+ # filehandle, and do the necessary mojo to create a new tty if we
+ # know how, and we can.
+ create_IN_OUT(4) if $CreateTTY & 4;
+ if ($console) {
+
+ # If we have a console, check to see if there are separate ins and
+ # outs to open. (They are assumed identical if not.)
+
+ my ( $i, $o ) = split /,/, $console;
+ $o = $i unless defined $o;
+
+ # read/write on in, or just read, or read on STDIN.
+ open( IN, "+<$i" )
+ || open( IN, "<$i" )
+ || open( IN, "<&STDIN" );
+
+ # read/write/create/clobber out, or write/create/clobber out,
+ # or merge with STDERR, or merge with STDOUT.
+ open( OUT, "+>$o" )
+ || open( OUT, ">$o" )
+ || open( OUT, ">&STDERR" )
+ || open( OUT, ">&STDOUT" ); # so we don't dongle stdout
+
+ } ## end if ($console)
+ elsif ( not defined $console ) {
+
+ # No console. Open STDIN.
+ open( IN, "<&STDIN" );
+
+ # merge with STDERR, or with STDOUT.
+ open( OUT, ">&STDERR" )
+ || open( OUT, ">&STDOUT" ); # so we don't dongle stdout
+ $console = 'STDIN/OUT';
+ } ## end elsif (not defined $console)
+
+ # Keep copies of the filehandles so that when the pager runs, it
+ # can close standard input without clobbering ours.
+ if ($console or (not defined($console))) {
+ $IN = \*IN;
+ $OUT = \*OUT;
+ }
+ } ## end elsif (from if(defined $remoteport))
+
+ # Unbuffer DB::OUT. We need to see responses right away.
+ _autoflush($OUT);
+
+ # Line info goes to debugger output unless pointed elsewhere.
+ # Pointing elsewhere makes it possible for slave editors to
+ # keep track of file and position. We have both a filehandle
+ # and a I/O description to keep track of.
+ $LINEINFO = $OUT unless defined $LINEINFO;
+ $lineinfo = $console unless defined $lineinfo;
+ # share($LINEINFO); # <- unable to share globs
+ share($lineinfo); #
+
+=pod
+
+To finish initialization, we show the debugger greeting,
+and then call the C<afterinit()> subroutine if there is one.
+
+=cut
+
+ # Show the debugger greeting.
+ $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
+
+
+ unless ($runnonstop) {
+ local $\ = '';
+ local $, = '';
+
+=pod
+ if ( $term_pid eq '-1' ) {
+ print $OUT "\nDaughter DB session started...\n";
+ }
+ else {
+ print $OUT "\nLoading DB routines from $header\n";
+ print $OUT (
+ "Editor support ",
+ $slave_editor ? "enabled" : "available", ".\n"
+ );
+ print $OUT
+"\nEnter h or 'h h' for help, or '$doccmd perldebug' for more help.\r\n";
+ } ## end else [ if ($term_pid eq '-1')
+=cut
+
+ print("\n");
+ print(" ____\n");
+ print(" / __/ __ ___ ___ ___ ___\n");
+ print(" _\\ \\/ _ \\/ -_) _ `/ __/ -_)\n");
+ print(" /___/ .__/\\__/\\_,_/_/ \\__/\n");
+ print(" /_/\n");
+ print("Speare Debug Server v0.0.1\n");
+ print("(c) 2019 http://sevenuc.com \n");
+
+ } ## end unless ($runnonstop)
+} ## end else [ if ($notty)
+
+# XXX This looks like a bug to me.
+# Why copy to @ARGS and then futz with @args?
+@ARGS = @ARGV;
+# for (@args) {
+ # Make sure backslashes before single quotes are stripped out, and
+ # keep args unless they are numeric (XXX why?)
+ # s/\'/\\\'/g; # removed while not justified understandably
+ # s/(.*)/'$1'/ unless /^-?[\d.]+$/; # ditto
+# }
+
+# If there was an afterinit() sub defined, call it. It will get
+# executed in our scope, so it can fiddle with debugger globals.
+if ( defined &afterinit ) { # May be defined in $rcfile
+ afterinit();
+}
+
+# Inform us about "Stack dump during die enabled ..." in dieLevel().
+use vars qw($I_m_init);
+
+$I_m_init = 1;
+
+############################################################ Subroutines
+
+=head1 SUBROUTINES
+
+=head2 DB
+
+This gigantic subroutine is the heart of the debugger. Called before every
+statement, its job is to determine if a breakpoint has been reached, and
+stop if so; read commands from the user, parse them, and execute
+them, and then send execution off to the next statement.
+
+Note that the order in which the commands are processed is very important;
+some commands earlier in the loop will actually alter the C<$cmd> variable
+to create other commands to be executed later. This is all highly I<optimized>
+but can be confusing. Check the comments for each C<$cmd ... && do {}> to
+see what's happening in any given command.
+
+=cut
+
+# $cmd cannot be an our() variable unfortunately (possible perl bug?).
+
+use vars qw(
+ $action
+ $cmd
+ $file
+ $filename_ini
+ $finished
+ %had_breakpoints
+ $level
+ $max
+ $package
+ $try
+);
+
+our (
+ %alias,
+ $doret,
+ $end,
+ $fall_off_end,
+ $incr,
+ $laststep,
+ $rc,
+ $sh,
+ $stack_depth,
+ @stack,
+ @to_watch,
+ @old_watch,
+);
+
+sub _DB__determine_if_we_should_break
+{
+ # if we have something here, see if we should break.
+ # $stop is lexical and local to this block - $action on the other hand
+ # is global.
+ my $stop;
+
+ if ( $dbline{$line}
+ && _is_breakpoint_enabled($filename, $line)
+ && (( $stop, $action ) = split( /\0/, $dbline{$line} ) ) )
+ {
+
+ # Stop if the stop criterion says to just stop.
+ if ( $stop eq '1' ) {
+ $signal |= 1;
+ }
+
+ # It's a conditional stop; eval it in the user's context and
+ # see if we should stop. If so, remove the one-time sigil.
+ elsif ($stop) {
+ $evalarg = "\$DB::signal |= 1 if do {$stop}";
+ # The &-call is here to ascertain the mutability of @_.
+ &DB::eval;
+ # If the breakpoint is temporary, then delete its enabled status.
+ if ($dbline{$line} =~ s/;9($|\0)/$1/) {
+ _cancel_breakpoint_temp_enabled_status($filename, $line);
+ }
+ }
+ } ## end if ($dbline{$line} && ...
+}
+
+sub _DB__is_finished {
+ if ($finished and $level <= 1) {
+ end_report();
+ return 1;
+ }
+ else {
+ return;
+ }
+}
+
+sub _DB__read_next_cmd
+{
+ my ($tid) = @_;
+
+ # We have a terminal, or can get one ...
+ if (!$term) {
+ setterm();
+ }
+
+ # ... and it belogs to this PID or we get one for this PID ...
+ if ($term_pid != $$) {
+ resetterm(1);
+ }
+
+ # ... and we got a line of command input ...
+
+ #$cmd = DB::readline(
+ # "$pidprompt $tid DB"
+ # . ( '<' x $level )
+ # . ( $#hist + 1 )
+ # . ( '>' x $level ) . " "
+ #);
+
+ $cmd = DB::readline();
+
+
+ return defined($cmd);
+}
+
+sub _DB__trim_command_and_return_first_component {
+ my ($obj) = @_;
+
+ $cmd =~ s/\A\s+//s; # trim annoying leading whitespace
+ $cmd =~ s/\s+\z//s; # trim annoying trailing whitespace
+
+ my ($verb, $args) = $cmd =~ m{\A(\S*)\s*(.*)}s;
+
+ $obj->cmd_verb($verb);
+ $obj->cmd_args($args);
+
+ return;
+}
+
+sub _DB__handle_f_command {
+ my ($obj) = @_;
+
+ if ($file = $obj->cmd_args) {
+ # help for no arguments (old-style was return from sub).
+ if ( !$file ) {
+ print $OUT
+ "The old f command is now the r command.\n"; # hint
+ print $OUT "The new f command switches filenames.\r\n";
+ next CMD;
+ } ## end if (!$file)
+
+ # if not in magic file list, try a close match.
+ if ( !defined $main::{ '_<' . $file } ) {
+ if ( ($try) = grep( m#^_<.*$file#, keys %main:: ) ) {
+ {
+ $try = substr( $try, 2 );
+ print $OUT "Choosing $try matching '$file':\r\n";
+ $file = $try;
+ }
+ } ## end if (($try) = grep(m#^_<.*$file#...
+ } ## end if (!defined $main::{ ...
+
+ # If not successfully switched now, we failed.
+ if ( !defined $main::{ '_<' . $file } ) {
+ print $OUT "No file matching '$file' is loaded.\r\n";
+ next CMD;
+ }
+
+ # We switched, so switch the debugger internals around.
+ elsif ( $file ne $filename ) {
+ *dbline = $main::{ '_<' . $file };
+ $max = $#dbline;
+ $filename = $file;
+ $start = 1;
+ $cmd = "l";
+ } ## end elsif ($file ne $filename)
+
+ # We didn't switch; say we didn't.
+ else {
+ print $OUT "Already in $file.\r\n";
+ next CMD;
+ }
+ }
+
+ return;
+}
+
+sub _DB__handle_dot_command {
+ my ($obj) = @_;
+
+ # . command.
+ if ($obj->_is_full('.')) {
+ $incr = -1; # stay at current line
+
+ # Reset everything to the old location.
+ $start = $line;
+ $filename = $filename_ini;
+ *dbline = $main::{ '_<' . $filename };
+ $max = $#dbline;
+
+ # Now where are we?
+ print_lineinfo($obj->position());
+ next CMD;
+ }
+
+ return;
+}
+
+sub _DB__handle_y_command {
+ my ($obj) = @_;
+
+ if (my ($match_level, $match_vars)
+ = $obj->cmd_args =~ /\A(?:(\d*)\s*(.*))?\z/) {
+
+ # See if we've got the necessary support.
+ if (!eval { require PadWalker; PadWalker->VERSION(0.08) }) {
+ my $Err = $@;
+ _db_warn(
+ $Err =~ /locate/
+ ? "PadWalker module not found - please install\r\n"
+ : $Err
+ );
+ next CMD;
+ }
+
+ # Load up dumpvar if we don't have it. If we can, that is.
+ do 'dumpvar.pl' || dir($@) unless defined &main::dumpvar;
+ defined &main::dumpvar
+ or print $OUT "\r\ndumpvar.pl not available.\r\n"
+ and next CMD;
+
+ # Got all the modules we need. Find them and print them.
+ my @vars = split( ' ', $match_vars || '' );
+
+ # Find the pad.
+ my $h = eval { PadWalker::peek_my( ( $match_level || 0 ) + 1 ) };
+
+ # Oops. Can't find it.
+ if (my $Err = $@) {
+ $Err =~ s/ at .*//;
+ _db_warn($Err);
+ next CMD;
+ }
+
+ # Show the desired vars with dumplex().
+ my $savout = select($OUT);
+
+ # Have dumplex dump the lexicals.
+ foreach my $key (sort keys %$h) {
+ dumpvar::dumplex( $key, $h->{$key},
+ defined $option{dumpDepth} ? $option{dumpDepth} : -1,
+ @vars );
+ }
+ select($savout);
+ next CMD;
+ }
+}
+
+sub _DB__handle_c_command {
+ my ($obj) = @_;
+
+ my $i = $obj->cmd_args;
+
+ if ($i =~ m#\A[\w:]*\z#) {
+
+ # Hey, show's over. The debugged program finished
+ # executing already.
+ next CMD if _DB__is_finished();
+
+ # Capture the place to put a one-time break.
+ $subname = $i;
+
+ # Probably not needed, since we finish an interactive
+ # sub-session anyway...
+ # local $filename = $filename;
+ # local *dbline = *dbline; # XXX Would this work?!
+ #
+ # The above question wonders if localizing the alias
+ # to the magic array works or not. Since it's commented
+ # out, we'll just leave that to speculation for now.
+
+ # If the "subname" isn't all digits, we'll assume it
+ # is a subroutine name, and try to find it.
+ if ( $subname =~ /\D/ ) { # subroutine name
+ # Qualify it to the current package unless it's
+ # already qualified.
+ $subname = $package . "::" . $subname
+ unless $subname =~ /::/;
+
+ # find_sub will return "file:line_number" corresponding
+ # to where the subroutine is defined; we call find_sub,
+ # break up the return value, and assign it in one
+ # operation.
+ ( $file, $i ) = ( find_sub($subname) =~ /^(.*):(.*)$/ );
+
+ # Force the line number to be numeric.
+ $i = $i + 0;
+
+ # If we got a line number, we found the sub.
+ if ($i) {
+
+ # Switch all the debugger's internals around so
+ # we're actually working with that file.
+ $filename = $file;
+ *dbline = $main::{ '_<' . $filename };
+
+ # Mark that there's a breakpoint in this file.
+ $had_breakpoints{$filename} |= 1;
+
+ # Scan forward to the first executable line
+ # after the 'sub whatever' line.
+ $max = $#dbline;
+ my $_line_num = $i;
+ while ($dbline[$_line_num] == 0 && $_line_num< $max)
+ {
+ $_line_num++;
+ }
+ $i = $_line_num;
+ } ## end if ($i)
+
+ # We didn't find a sub by that name.
+ else {
+ print $OUT "Subroutine $subname not found.\r\n";
+ next CMD;
+ }
+ } ## end if ($subname =~ /\D/)
+
+ # At this point, either the subname was all digits (an
+ # absolute line-break request) or we've scanned through
+ # the code following the definition of the sub, looking
+ # for an executable, which we may or may not have found.
+ #
+ # If $i (which we set $subname from) is non-zero, we
+ # got a request to break at some line somewhere. On
+ # one hand, if there wasn't any real subroutine name
+ # involved, this will be a request to break in the current
+ # file at the specified line, so we have to check to make
+ # sure that the line specified really is breakable.
+ #
+ # On the other hand, if there was a subname supplied, the
+ # preceding block has moved us to the proper file and
+ # location within that file, and then scanned forward
+ # looking for the next executable line. We have to make
+ # sure that one was found.
+ #
+ # On the gripping hand, we can't do anything unless the
+ # current value of $i points to a valid breakable line.
+ # Check that.
+ if ($i) {
+
+ # Breakable?
+ if ( $dbline[$i] == 0 ) {
+ print $OUT "Line $i not breakable.\r\n";
+ next CMD;
+ }
+
+ # Yes. Set up the one-time-break sigil.
+ $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
+ _enable_breakpoint_temp_enabled_status($filename, $i);
+ } ## end if ($i)
+
+ # Turn off stack tracing from here up.
+ for my $j (0 .. $stack_depth) {
+ $stack[ $j ] &= ~1;
+ }
+ last CMD;
+ }
+
+ return;
+}
+
+sub _DB__handle_forward_slash_command {
+ my ($obj) = @_;
+
+ # The pattern as a string.
+ use vars qw($inpat);
+
+ if (($inpat) = $cmd =~ m#\A/(.*)\z#) {
+
+ # Remove the final slash.
+ $inpat =~ s:([^\\])/$:$1:;
+
+ # If the pattern isn't null ...
+ if ( $inpat ne "" ) {
+
+ # Turn of warn and die procesing for a bit.
+ local $SIG{__DIE__};
+ local $SIG{__WARN__};
+
+ # Create the pattern.
+ eval 'no strict q/vars/; $inpat =~ m' . "\a$inpat\a";
+ if ( $@ ne "" ) {
+
+ # Oops. Bad pattern. No biscuit.
+ # Print the eval error and go back for more
+ # commands.
+ print "\r\n";
+ print {$OUT} "$@";
+ print "\r\n";
+ next CMD;
+ }
+ $obj->pat($inpat);
+ } ## end if ($inpat ne "")
+
+ # Set up to stop on wrap-around.
+ $end = $start;
+
+ # Don't move off the current line.
+ $incr = -1;
+
+ my $pat = $obj->pat;
+
+ # Done in eval so nothing breaks if the pattern
+ # does something weird.
+ eval
+ {
+ no strict q/vars/;
+ for (;;) {
+ # Move ahead one line.
+ ++$start;
+
+ # Wrap if we pass the last line.
+ if ($start > $max) {
+ $start = 1;
+ }
+
+ # Stop if we have gotten back to this line again,
+ last if ($start == $end);
+
+ # A hit! (Note, though, that we are doing
+ # case-insensitive matching. Maybe a qr//
+ # expression would be better, so the user could
+ # do case-sensitive matching if desired.
+ if ($dbline[$start] =~ m/$pat/i) {
+ if ($slave_editor) {
+ # Handle proper escaping in the slave.
+ print {$OUT} "\032\032$filename:$start:0\r\n";
+ }
+ else {
+ # Just print the line normally.
+ print {$OUT} "$start:\t",$dbline[$start],"\r\n";
+ }
+ # And quit since we found something.
+ last;
+ }
+ }
+ };
+
+ if ($@) {
+ warn $@;
+ }
+
+ # If we wrapped, there never was a match.
+ if ( $start == $end ) {
+ print {$OUT} "/$pat/: not found\r\n";
+ }
+ next CMD;
+ }
+
+ return;
+}
+
+sub _DB__handle_question_mark_command {
+ my ($obj) = @_;
+
+ # ? - backward pattern search.
+ if (my ($inpat) = $cmd =~ m#\A\?(.*)\z#) {
+
+ # Get the pattern, remove trailing question mark.
+ $inpat =~ s:([^\\])\?$:$1:;
+
+ # If we've got one ...
+ if ( $inpat ne "" ) {
+
+ # Turn off die & warn handlers.
+ local $SIG{__DIE__};
+ local $SIG{__WARN__};
+ eval '$inpat =~ m' . "\a$inpat\a";
+
+ if ( $@ ne "" ) {
+
+ # Ouch. Not good. Print the error.
+ print "\r\n";
+ print $OUT $@;
+ print "\r\n";
+ next CMD;
+ }
+ $obj->pat($inpat);
+ } ## end if ($inpat ne "")
+
+ # Where we are now is where to stop after wraparound.
+ $end = $start;
+
+ # Don't move away from this line.
+ $incr = -1;
+
+ my $pat = $obj->pat;
+ # Search inside the eval to prevent pattern badness
+ # from killing us.
+ eval {
+ no strict q/vars/;
+ for (;;) {
+ # Back up a line.
+ --$start;
+
+ # Wrap if we pass the first line.
+
+ $start = $max if ($start <= 0);
+
+ # Quit if we get back where we started,
+ last if ($start == $end);
+
+ # Match?
+ if ($dbline[$start] =~ m/$pat/i) {
+ if ($slave_editor) {
+ # Yep, follow slave editor requirements.
+ print $OUT "\032\032$filename:$start:0\r\n";
+ }
+ else {
+ # Yep, just print normally.
+ print $OUT "$start:\t",$dbline[$start],"\r\n";
+ }
+
+ # Found, so done.
+ last;
+ }
+ }
+ };
+
+ # Say we failed if the loop never found anything,
+ if ( $start == $end ) {
+ print {$OUT} "?$pat?: not found\r\n";
+ }
+ next CMD;
+ }
+
+ return;
+}
+
+sub _DB__handle_restart_and_rerun_commands {
+ my ($obj) = @_;
+
+ my $cmd_cmd = $obj->cmd_verb;
+ my $cmd_params = $obj->cmd_args;
+ # R - restart execution.
+ # rerun - controlled restart execution.
+ if ($cmd_cmd eq 'rerun' or $cmd_params eq '') {
+ my @args = ($cmd_cmd eq 'R' ? restart() : rerun($cmd_params));
+
+ # Close all non-system fds for a clean restart. A more
+ # correct method would be to close all fds that were not
+ # open when the process started, but this seems to be
+ # hard. See "debugger 'R'estart and open database
+ # connections" on p5p.
+
+ my $max_fd = 1024; # default if POSIX can't be loaded
+ if (eval { require POSIX }) {
+ eval { $max_fd = POSIX::sysconf(POSIX::_SC_OPEN_MAX()) };
+ }
+
+ if (defined $max_fd) {
+ foreach ($^F+1 .. $max_fd-1) {
+ next unless open FD_TO_CLOSE, "<&=$_";
+ close(FD_TO_CLOSE);
+ }
+ }
+
+ # And run Perl again. We use exec() to keep the
+ # PID stable (and that way $ini_pids is still valid).
+ exec(@args) or print {$OUT} "exec failed: $!\r\n";
+
+ last CMD;
+ }
+
+ return;
+}
+
+sub _DB__handle_run_command_in_pager_command {
+ my ($obj) = @_;
+
+ if ($cmd =~ m#\A\|\|?\s*[^|]#) {
+ if ( $pager =~ /^\|/ ) {
+
+ # Default pager is into a pipe. Redirect I/O.
+ open( SAVEOUT, ">&STDOUT" )
+ || _db_warn("Can't save STDOUT");
+ open( STDOUT, ">&OUT" )
+ || _db_warn("Can't redirect STDOUT");
+ } ## end if ($pager =~ /^\|/)
+ else {
+
+ # Not into a pipe. STDOUT is safe.
+ open( SAVEOUT, ">&OUT" ) || _db_warn("Can't save DB::OUT");
+ }
+
+ # Fix up environment to record we have less if so.
+ fix_less();
+
+ unless ( $obj->piped(scalar ( open( OUT, $pager ) ) ) ) {
+
+ # Couldn't open pipe to pager.
+ _db_warn("Can't pipe output to '$pager'");
+ if ( $pager =~ /^\|/ ) {
+
+ # Redirect I/O back again.
+ open( OUT, ">&STDOUT" ) # XXX: lost message
+ || _db_warn("Can't restore DB::OUT");
+ open( STDOUT, ">&SAVEOUT" )
+ || _db_warn("Can't restore STDOUT");
+ close(SAVEOUT);
+ } ## end if ($pager =~ /^\|/)
+ else {
+
+ # Redirect I/O. STDOUT already safe.
+ open( OUT, ">&STDOUT" ) # XXX: lost message
+ || _db_warn("Can't restore DB::OUT");
+ }
+ next CMD;
+ } ## end unless ($piped = open(OUT,...
+
+ # Set up broken-pipe handler if necessary.
+ $SIG{PIPE} = \&DB::catch
+ if $pager =~ /^\|/
+ && ( "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE} );
+
+ _autoflush(\*OUT);
+ # Save current filehandle, and put it back.
+ $obj->selected(scalar( select(OUT) ));
+ # Don't put it back if pager was a pipe.
+ if ($cmd !~ /\A\|\|/)
+ {
+ select($obj->selected());
+ $obj->selected("");
+ }
+
+ # Trim off the pipe symbols and run the command now.
+ $cmd =~ s#\A\|+\s*##;
+ redo PIPE;
+ }
+
+ return;
+}
+
+sub _DB__handle_m_command {
+ my ($obj) = @_;
+
+ if ($cmd =~ s#\Am\s+([\w:]+)\s*\z# #) {
+ methods($1);
+ next CMD;
+ }
+
+ # m expr - set up DB::eval to do the work
+ if ($cmd =~ s#\Am\b# #) { # Rest gets done by DB::eval()
+ $onetimeDump = 'methods'; # method output gets used there
+ }
+
+ return;
+}
+
+sub _DB__at_end_of_every_command {
+ my ($obj) = @_;
+
+ # At the end of every command:
+ if ($obj->piped) {
+
+ # Unhook the pipe mechanism now.
+ if ( $pager =~ /^\|/ ) {
+
+ # No error from the child.
+ $? = 0;
+
+ # we cannot warn here: the handle is missing --tchrist
+ close(OUT) || print SAVEOUT "\r\nCan't close DB::OUT\r\n";
+
+ # most of the $? crud was coping with broken cshisms
+ # $? is explicitly set to 0, so this never runs.
+ if ($?) {
+ print SAVEOUT "\r\nPager '$pager' failed: ";
+ if ( $? == -1 ) {
+ print SAVEOUT "shell returned -1\r\n";
+ }
+ elsif ( $? >> 8 ) {
+ print SAVEOUT ( $? & 127 )
+ ? " (SIG#" . ( $? & 127 ) . ")"
+ : "", ( $? & 128 ) ? " -- core dumped" : "", "\r\n";
+ }
+ else {
+ print SAVEOUT "status ", ( $? >> 8 ), "\r\n";
+ }
+ } ## end if ($?)
+
+ # Reopen filehandle for our output (if we can) and
+ # restore STDOUT (if we can).
+ open( OUT, ">&STDOUT" ) || _db_warn("Can't restore DB::OUT");
+ open( STDOUT, ">&SAVEOUT" )
+ || _db_warn("Can't restore STDOUT");
+
+ # Turn off pipe exception handler if necessary.
+ $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
+
+ # Will stop ignoring SIGPIPE if done like nohup(1)
+ # does SIGINT but Perl doesn't give us a choice.
+ } ## end if ($pager =~ /^\|/)
+ else {
+
+ # Non-piped "pager". Just restore STDOUT.
+ open( OUT, ">&SAVEOUT" ) || _db_warn("Can't restore DB::OUT");
+ }
+
+ # Let Readline know about the new filehandles.
+ reset_IN_OUT( \*IN, \*OUT );
+
+ # Close filehandle pager was using, restore the normal one
+ # if necessary,
+ close(SAVEOUT);
+
+ if ($obj->selected() ne "") {
+ select($obj->selected);
+ $obj->selected("");
+ }
+
+ # No pipes now.
+ $obj->piped("");
+ } ## end if ($piped)
+
+ return;
+}
+
+sub _DB__handle_watch_expressions
+{
+ my $self = shift;
+
+ if ( $DB::trace & 2 ) {
+ for my $n (0 .. $#DB::to_watch) {
+ $DB::evalarg = $DB::to_watch[$n];
+ local $DB::onetimeDump; # Tell DB::eval() to not output results
+
+ # Fix context DB::eval() wants to return an array, but
+ # we need a scalar here.
+ my ($val) = join( "', '", DB::eval(@_) );
+ $val = ( ( defined $val ) ? "'$val'" : 'undef' );
+
+ # Did it change?
+ if ( $val ne $DB::old_watch[$n] ) {
+
+ # Yep! Show the difference, and fake an interrupt.
+ $DB::signal = 1;
+ print {$DB::OUT} <<EOP;
+Watchpoint $n:\t$DB::to_watch[$n] changed:
+ old value:\t$DB::old_watch[$n]
+ new value:\t$val
+EOP
+ $DB::old_watch[$n] = $val;
+ } ## end if ($val ne $old_watch...
+ } ## end for my $n (0 ..
+ } ## end if ($trace & 2)
+
+ return;
+}
+
+# 't' is type.
+# 'm' is method.
+# 'v' is the value (i.e: method name or subroutine ref).
+# 's' is subroutine.
+my %cmd_lookup =
+(
+ '-' => { t => 'm', v => '_handle_dash_command', },
+ '.' => { t => 's', v => \&_DB__handle_dot_command, },
+ '=' => { t => 'm', v => '_handle_equal_sign_command', },
+ 'H' => { t => 'm', v => '_handle_H_command', },
+ 'S' => { t => 'm', v => '_handle_S_command', },
+ 'T' => { t => 'm', v => '_handle_T_command', },
+ 'W' => { t => 'm', v => '_handle_W_command', },
+ 'c' => { t => 's', v => \&_DB__handle_c_command, },
+ 'f' => { t => 's', v => \&_DB__handle_f_command, },
+ 'm' => { t => 's', v => \&_DB__handle_m_command, },
+ 'n' => { t => 'm', v => '_handle_n_command', },
+ 'p' => { t => 'm', v => '_handle_p_command', },
+ 'q' => { t => 'm', v => '_handle_q_command', },
+ 'r' => { t => 'm', v => '_handle_r_command', },
+ 's' => { t => 'm', v => '_handle_s_command', },
+ 'save' => { t => 'm', v => '_handle_save_command', },
+ 'source' => { t => 'm', v => '_handle_source_command', },
+ 't' => { t => 'm', v => '_handle_t_command', },
+ 'w' => { t => 'm', v => '_handle_w_command', },
+ 'x' => { t => 'm', v => '_handle_x_command', },
+ 'y' => { t => 's', v => \&_DB__handle_y_command, },
+ (map { $_ => { t => 'm', v => '_handle_V_command_and_X_command', }, }
+ ('X', 'V')),
+ (map { $_ => { t => 'm', v => '_handle_enable_disable_commands', }, }
+ qw(enable disable)),
+ (map { $_ =>
+ { t => 's', v => \&_DB__handle_restart_and_rerun_commands, },
+ } qw(R rerun)),
+ (map { $_ => {t => 'm', v => '_handle_cmd_wrapper_commands' }, }
+ qw(a A b B e E h i l L M o O P v w W)),
+);
+
+sub DB {
+
+ # lock the debugger and get the thread id for the prompt
+ lock($DBGR);
+ my $tid;
+ my $position;
+ my ($prefix, $after, $infix);
+ my $pat;
+ my $explicit_stop;
+ my $piped;
+ my $selected;
+
+ if ($ENV{PERL5DB_THREADED}) {
+ $tid = eval { "[".threads->tid."]" };
+ }
+
+ my $cmd_verb;
+ my $cmd_args;
+
+ my $obj = DB::Obj->new(
+ {
+ position => \$position,
+ prefix => \$prefix,
+ after => \$after,
+ explicit_stop => \$explicit_stop,
+ infix => \$infix,
+ cmd_args => \$cmd_args,
+ cmd_verb => \$cmd_verb,
+ pat => \$pat,
+ piped => \$piped,
+ selected => \$selected,
+ },
+ );
+
+ $obj->_DB_on_init__initialize_globals(@_);
+
+ # Preserve current values of $@, $!, $^E, $,, $/, $\, $^W.
+ # The code being debugged may have altered them.
+ DB::save();
+
+ # Since DB::DB gets called after every line, we can use caller() to
+ # figure out where we last were executing. Sneaky, eh? This works because
+ # caller is returning all the extra information when called from the
+ # debugger.
+ local ( $package, $filename, $line ) = caller;
+ $filename_ini = $filename;
+
+ # set up the context for DB::eval, so it can properly execute
+ # code on behalf of the user. We add the package in so that the
+ # code is eval'ed in the proper package (not in the debugger!).
+ local $usercontext = _calc_usercontext($package);
+
+ # Create an alias to the active file magical array to simplify
+ # the code here.
+ local (*dbline) = $main::{ '_<' . $filename };
+
+ # Last line in the program.
+ $max = $#dbline;
+
+ # The &-call is here to ascertain the mutability of @_.
+ &_DB__determine_if_we_should_break;
+
+ # Preserve the current stop-or-not, and see if any of the W
+ # (watch expressions) has changed.
+ my $was_signal = $signal;
+
+ # If we have any watch expressions ...
+ _DB__handle_watch_expressions($obj);
+
+=head2 C<watchfunction()>
+
+C<watchfunction()> is a function that can be defined by the user; it is a
+function which will be run on each entry to C<DB::DB>; it gets the
+current package, filename, and line as its parameters.
+
+The watchfunction can do anything it likes; it is executing in the
+debugger's context, so it has access to all of the debugger's internal
+data structures and functions.
+
+C<watchfunction()> can control the debugger's actions. Any of the following
+will cause the debugger to return control to the user's program after
+C<watchfunction()> executes:
+
+=over 4
+
+=item *
+
+Returning a false value from the C<watchfunction()> itself.
+
+=item *
+
+Altering C<$single> to a false value.
+
+=item *
+
+Altering C<$signal> to a false value.
+
+=item *
+
+Turning off the C<4> bit in C<$trace> (this also disables the
+check for C<watchfunction()>. This can be done with
+
+ $trace &= ~4;
+
+=back
+
+=cut
+
+ # If there's a user-defined DB::watchfunction, call it with the
+ # current package, filename, and line. The function executes in
+ # the DB:: package.
+ if ( $trace & 4 ) { # User-installed watch
+ return
+ if watchfunction( $package, $filename, $line )
+ and not $single
+ and not $was_signal
+ and not( $trace & ~4 );
+ } ## end if ($trace & 4)
+
+ # Pick up any alteration to $signal in the watchfunction, and
+ # turn off the signal now.
+ $was_signal = $signal;
+ $signal = 0;
+
+=head2 GETTING READY TO EXECUTE COMMANDS
+
+The debugger decides to take control if single-step mode is on, the
+C<t> command was entered, or the user generated a signal. If the program
+has fallen off the end, we set things up so that entering further commands
+won't cause trouble, and we say that the program is over.
+
+=cut
+
+ # Make sure that we always print if asked for explicitly regardless
+ # of $trace_to_depth .
+ $explicit_stop = ($single || $was_signal);
+
+ # Check to see if we should grab control ($single true,
+ # trace set appropriately, or we got a signal).
+ if ( $explicit_stop || ( $trace & 1 ) ) {
+ $obj->_DB__grab_control(@_);
+ } ## end if ($single || ($trace...
+
+=pod
+
+If there's an action to be executed for the line we stopped at, execute it.
+If there are any preprompt actions, execute those as well.
+
+=cut
+
+ # If there's an action, do it now.
+ if ($action) {
+ $evalarg = $action;
+ # The &-call is here to ascertain the mutability of @_.
+ &DB::eval;
+ }
+
+ # Are we nested another level (e.g., did we evaluate a function
+ # that had a breakpoint in it at the debugger prompt)?
+ if ( $single || $was_signal ) {
+
+ # Yes, go down a level.
+ local $level = $level + 1;
+
+ # Do any pre-prompt actions.
+ foreach $evalarg (@$pre) {
+ # The &-call is here to ascertain the mutability of @_.
+ &DB::eval;
+ }
+
+ # Complain about too much recursion if we passed the limit.
+ if ($single & 4) {
+ print $OUT $stack_depth . " levels deep in subroutine calls!\r\n";
+ }
+
+ # The line we're currently on. Set $incr to -1 to stay here
+ # until we get a command that tells us to advance.
+ $start = $line;
+ $incr = -1; # for backward motion.
+
+ # Tack preprompt debugger actions ahead of any actual input.
+ @typeahead = ( @$pretype, @typeahead );
+
+=head2 WHERE ARE WE?
+
+XXX Relocate this section?
+
+The debugger normally shows the line corresponding to the current line of
+execution. Sometimes, though, we want to see the next line, or to move elsewhere
+in the file. This is done via the C<$incr>, C<$start>, and C<$max> variables.
+
+C<$incr> controls by how many lines the I<current> line should move forward
+after a command is executed. If set to -1, this indicates that the I<current>
+line shouldn't change.
+
+C<$start> is the I<current> line. It is used for things like knowing where to
+move forwards or backwards from when doing an C<L> or C<-> command.
+
+C<$max> tells the debugger where the last line of the current file is. It's
+used to terminate loops most often.
+
+=head2 THE COMMAND LOOP
+
+Most of C<DB::DB> is actually a command parsing and dispatch loop. It comes
+in two parts:
+
+=over 4
+
+=item *
+
+The outer part of the loop, starting at the C<CMD> label. This loop
+reads a command and then executes it.
+
+=item *
+
+The inner part of the loop, starting at the C<PIPE> label. This part
+is wholly contained inside the C<CMD> block and only executes a command.
+Used to handle commands running inside a pager.
+
+=back
+
+So why have two labels to restart the loop? Because sometimes, it's easier to
+have a command I<generate> another command and then re-execute the loop to do
+the new command. This is faster, but perhaps a bit more convoluted.
+
+=cut
+
+ # The big command dispatch loop. It keeps running until the
+ # user yields up control again.
+ #
+ # If we have a terminal for input, and we get something back
+ # from readline(), keep on processing.
+
+ CMD:
+ while (_DB__read_next_cmd($tid))
+ {
+
+ share($cmd);
+ # ... try to execute the input as debugger commands.
+
+ # Don't stop running.
+ $single = 0;
+
+ # No signal is active.
+ $signal = 0;
+
+ # Handle continued commands (ending with \):
+ if ($cmd =~ s/\\\z/\n/) {
+ $cmd .= DB::readline(" cont: ");
+ redo CMD;
+ }
+
+=head4 The null command
+
+A newline entered by itself means I<re-execute the last command>. We grab the
+command out of C<$laststep> (where it was recorded previously), and copy it
+back into C<$cmd> to be executed below. If there wasn't any previous command,
+we'll do nothing below (no command will match). If there was, we also save it
+in the command history and fall through to allow the command parsing to pick
+it up.
+
+=cut
+
+ # Empty input means repeat the last command.
+ if ($cmd eq '') {
+ $cmd = $laststep;
+ }
+ chomp($cmd); # get rid of the annoying extra newline
+ if (length($cmd) >= 2) {
+ push( @hist, $cmd );
+ }
+ push( @truehist, $cmd );
+ share(@hist);
+ share(@truehist);
+
+ # This is a restart point for commands that didn't arrive
+ # via direct user input. It allows us to 'redo PIPE' to
+ # re-execute command processing without reading a new command.
+ PIPE: {
+ _DB__trim_command_and_return_first_component($obj);
+
+=head3 COMMAND ALIASES
+
+The debugger can create aliases for commands (these are stored in the
+C<%alias> hash). Before a command is executed, the command loop looks it up
+in the alias hash and substitutes the contents of the alias for the command,
+completely replacing it.
+
+=cut
+
+ # See if there's an alias for the command, and set it up if so.
+ if ( $alias{$cmd_verb} ) {
+
+ # Squelch signal handling; we want to keep control here
+ # if something goes loco during the alias eval.
+ local $SIG{__DIE__};
+ local $SIG{__WARN__};
+
+ # This is a command, so we eval it in the DEBUGGER's
+ # scope! Otherwise, we can't see the special debugger
+ # variables, or get to the debugger's subs. (Well, we
+ # _could_, but why make it even more complicated?)
+ eval "\$cmd =~ $alias{$cmd_verb}";
+ if ($@) {
+ local $\ = '';
+ print $OUT "Couldn't evaluate '$cmd_verb' alias: $@";
+ print $OUT "\r\n";
+ next CMD;
+ }
+ _DB__trim_command_and_return_first_component($obj);
+ } ## end if ($alias{$cmd_verb})
+
+=head3 MAIN-LINE COMMANDS
+
+All of these commands work up to and after the program being debugged has
+terminated.
+
+=head4 C<q> - quit
+
+Quit the debugger. This entails setting the C<$fall_off_end> flag, so we don't
+try to execute further, cleaning any restart-related stuff out of the
+environment, and executing with the last value of C<$?>.
+
+=cut
+
+ # All of these commands were remapped in perl 5.8.0;
+ # we send them off to the secondary dispatcher (see below).
+ $obj->_handle_special_char_cmd_wrapper_commands;
+ _DB__trim_command_and_return_first_component($obj);
+
+
+ #print "\r\n cmd_verb = $cmd_verb\r\n";
+
+ if (my $cmd_rec = $cmd_lookup{$cmd_verb}) {
+ my $type = $cmd_rec->{t};
+ my $val = $cmd_rec->{v};
+ if ($type eq 'm') {
+ $obj->$val();
+ }
+ elsif ($type eq 's') {
+ $val->($obj);
+ }
+ }
+
+=head4 C<t> - trace [n]
+
+Turn tracing on or off. Inverts the appropriate bit in C<$trace> (q.v.).
+If level is specified, set C<$trace_to_depth>.
+
+=head4 C<S> - list subroutines matching/not matching a pattern
+
+Walks through C<%sub>, checking to see whether or not to print the name.
+
+=head4 C<X> - list variables in current package
+
+Since the C<V> command actually processes this, just change this to the
+appropriate C<V> command and fall through.
+
+=head4 C<V> - list variables
+
+Uses C<dumpvar.pl> to dump out the current values for selected variables.
+
+=head4 C<x> - evaluate and print an expression
+
+Hands the expression off to C<DB::eval>, setting it up to print the value
+via C<dumpvar.pl> instead of just printing it directly.
+
+=head4 C<m> - print methods
+
+Just uses C<DB::methods> to determine what methods are available.
+
+=head4 C<f> - switch files
+
+Switch to a different filename.
+
+=head4 C<.> - return to last-executed line.
+
+We set C<$incr> to -1 to indicate that the debugger shouldn't move ahead,
+and then we look up the line in the magical C<%dbline> hash.
+
+=head4 C<-> - back one window
+
+We change C<$start> to be one window back; if we go back past the first line,
+we set it to be the first line. We ser C<$incr> to put us back at the
+currently-executing line, and then put a C<l $start +> (list one window from
+C<$start>) in C<$cmd> to be executed later.
+
+=head3 PRE-580 COMMANDS VS. NEW COMMANDS: C<a, A, b, B, h, l, L, M, o, O, P, v, w, W, E<lt>, E<lt>E<lt>, E<0x7B>, E<0x7B>E<0x7B>>
+
+In Perl 5.8.0, a realignment of the commands was done to fix up a number of
+problems, most notably that the default case of several commands destroying
+the user's work in setting watchpoints, actions, etc. We wanted, however, to
+retain the old commands for those who were used to using them or who preferred
+them. At this point, we check for the new commands and call C<cmd_wrapper> to
+deal with them instead of processing them in-line.
+
+=head4 C<y> - List lexicals in higher scope
+
+Uses C<PadWalker> to find the lexicals supplied as arguments in a scope
+above the current one and then displays then using C<dumpvar.pl>.
+
+=head3 COMMANDS NOT WORKING AFTER PROGRAM ENDS
+
+All of the commands below this point don't work after the program being
+debugged has ended. All of them check to see if the program has ended; this
+allows the commands to be relocated without worrying about a 'line of
+demarcation' above which commands can be entered anytime, and below which
+they can't.
+
+=head4 C<n> - single step, but don't trace down into subs
+
+Done by setting C<$single> to 2, which forces subs to execute straight through
+when entered (see C<DB::sub>). We also save the C<n> command in C<$laststep>,
+so a null command knows what to re-execute.
+
+=head4 C<s> - single-step, entering subs
+
+Sets C<$single> to 1, which causes C<DB::sub> to continue tracing inside
+subs. Also saves C<s> as C<$lastcmd>.
+
+=head4 C<c> - run continuously, setting an optional breakpoint
+
+Most of the code for this command is taken up with locating the optional
+breakpoint, which is either a subroutine name or a line number. We set
+the appropriate one-time-break in C<@dbline> and then turn off single-stepping
+in this and all call levels above this one.
+
+=head4 C<r> - return from a subroutine
+
+For C<r> to work properly, the debugger has to stop execution again
+immediately after the return is executed. This is done by forcing
+single-stepping to be on in the call level above the current one. If
+we are printing return values when a C<r> is executed, set C<$doret>
+appropriately, and force us out of the command loop.
+
+=head4 C<T> - stack trace
+
+Just calls C<DB::print_trace>.
+
+=head4 C<w> - List window around current line.
+
+Just calls C<DB::cmd_w>.
+
+=head4 C<W> - watch-expression processing.
+
+Just calls C<DB::cmd_W>.
+
+=head4 C</> - search forward for a string in the source
+
+We take the argument and treat it as a pattern. If it turns out to be a
+bad one, we return the error we got from trying to C<eval> it and exit.
+If not, we create some code to do the search and C<eval> it so it can't
+mess us up.
+
+=cut
+
+ _DB__handle_forward_slash_command($obj);
+
+=head4 C<?> - search backward for a string in the source
+
+Same as for C</>, except the loop runs backwards.
+
+=cut
+
+ _DB__handle_question_mark_command($obj);
+
+=head4 C<$rc> - Recall command
+
+Manages the commands in C<@hist> (which is created if C<Term::ReadLine> reports
+that the terminal supports history). It find the the command required, puts it
+into C<$cmd>, and redoes the loop to execute it.
+
+=cut
+
+ # $rc - recall command.
+ $obj->_handle_rc_recall_command;
+
+=head4 C<$sh$sh> - C<system()> command
+
+Calls the C<_db_system()> to handle the command. This keeps the C<STDIN> and
+C<STDOUT> from getting messed up.
+
+=cut
+
+ $obj->_handle_sh_command;
+
+=head4 C<$rc I<pattern> $rc> - Search command history
+
+Another command to manipulate C<@hist>: this one searches it with a pattern.
+If a command is found, it is placed in C<$cmd> and executed via C<redo>.
+
+=cut
+
+ $obj->_handle_rc_search_history_command;
+
+=head4 C<$sh> - Invoke a shell
+
+Uses C<_db_system()> to invoke a shell.
+
+=cut
+
+=head4 C<$sh I<command>> - Force execution of a command in a shell
+
+Like the above, but the command is passed to the shell. Again, we use
+C<_db_system()> to avoid problems with C<STDIN> and C<STDOUT>.
+
+=head4 C<H> - display commands in history
+
+Prints the contents of C<@hist> (if any).
+
+=head4 C<man, doc, perldoc> - look up documentation
+
+Just calls C<runman()> to print the appropriate document.
+
+=cut
+
+ $obj->_handle_doc_command;
+
+=head4 C<p> - print
+
+Builds a C<print EXPR> expression in the C<$cmd>; this will get executed at
+the bottom of the loop.
+
+=head4 C<=> - define command alias
+
+Manipulates C<%alias> to add or list command aliases.
+
+=head4 C<source> - read commands from a file.
+
+Opens a lexical filehandle and stacks it on C<@cmdfhs>; C<DB::readline> will
+pick it up.
+
+=head4 C<enable> C<disable> - enable or disable breakpoints
+
+This enables or disables breakpoints.
+
+=head4 C<save> - send current history to a file
+
+Takes the complete history, (not the shrunken version you see with C<H>),
+and saves it to the given filename, so it can be replayed using C<source>.
+
+Note that all C<^(save|source)>'s are commented out with a view to minimise recursion.
+
+=head4 C<R> - restart
+
+Restart the debugger session.
+
+=head4 C<rerun> - rerun the current session
+
+Return to any given position in the B<true>-history list
+
+=head4 C<|, ||> - pipe output through the pager.
+
+For C<|>, we save C<OUT> (the debugger's output filehandle) and C<STDOUT>
+(the program's standard output). For C<||>, we only save C<OUT>. We open a
+pipe to the pager (restoring the output filehandles if this fails). If this
+is the C<|> command, we also set up a C<SIGPIPE> handler which will simply
+set C<$signal>, sending us back into the debugger.
+
+We then trim off the pipe symbols and C<redo> the command loop at the
+C<PIPE> label, causing us to evaluate the command in C<$cmd> without
+reading another.
+
+=cut
+
+ # || - run command in the pager, with output to DB::OUT.
+ _DB__handle_run_command_in_pager_command($obj);
+
+=head3 END OF COMMAND PARSING
+
+Anything left in C<$cmd> at this point is a Perl expression that we want to
+evaluate. We'll always evaluate in the user's context, and fully qualify
+any variables we might want to address in the C<DB> package.
+
+=cut
+
+ } # PIPE:
+
+ # trace an expression
+ $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
+
+ # Make sure the flag that says "the debugger's running" is
+ # still on, to make sure we get control again.
+ $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd";
+
+ # Run *our* eval that executes in the caller's context.
+ # The &-call is here to ascertain the mutability of @_.
+ &DB::eval;
+
+ # Turn off the one-time-dump stuff now.
+ if ($onetimeDump) {
+ $onetimeDump = undef;
+ $onetimedumpDepth = undef;
+ }
+ elsif ( $term_pid == $$ ) {
+ eval { # May run under miniperl, when not available...
+ STDOUT->flush();
+ STDERR->flush();
+ };
+
+ # XXX If this is the master pid, print a newline.
+ print {$OUT} "\r\n";
+ }
+ } ## end while (($term || &setterm...
+
+=head3 POST-COMMAND PROCESSING
+
+After each command, we check to see if the command output was piped anywhere.
+If so, we go through the necessary code to unhook the pipe and go back to
+our standard filehandles for input and output.
+
+=cut
+
+ continue { # CMD:
+ _DB__at_end_of_every_command($obj);
+ } # CMD:
+
+=head3 COMMAND LOOP TERMINATION
+
+When commands have finished executing, we come here. If the user closed the
+input filehandle, we turn on C<$fall_off_end> to emulate a C<q> command. We
+evaluate any post-prompt items. We restore C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>,
+C<$\>, and C<$^W>, and return a null list as expected by the Perl interpreter.
+The interpreter will then execute the next line and then return control to us
+again.
+
+=cut
+
+ # No more commands? Quit.
+ $fall_off_end = 1 unless defined $cmd; # Emulate 'q' on EOF
+
+ # Evaluate post-prompt commands.
+ foreach $evalarg (@$post) {
+ # The &-call is here to ascertain the mutability of @_.
+ &DB::eval;
+ }
+ } # if ($single || $signal)
+
+ # Put the user's globals back where you found them.
+ ( $@, $!, $^E, $,, $/, $\, $^W ) = @saved;
+ ();
+} ## end sub DB
+
+# Because DB::Obj is used above,
+#
+# my $obj = DB::Obj->new(
+#
+# The following package declaraton must come before that,
+# or else runtime errors will occur with
+#
+# PERLDB_OPTS="autotrace nonstop"
+#
+# ( rt#116771 )
+
+BEGIN {
+
+package DB::Obj;
+
+sub new {
+ my $class = shift;
+
+ my $self = bless {}, $class;
+
+ $self->_init(@_);
+
+ return $self;
+}
+
+sub _init {
+ my ($self, $args) = @_;
+
+ %{$self} = (%$self, %$args);
+
+ return;
+}
+
+{
+ no strict 'refs';
+ foreach my $slot_name (qw(
+ after explicit_stop infix pat piped position prefix selected cmd_verb
+ cmd_args
+ )) {
+ my $slot = $slot_name;
+ *{$slot} = sub {
+ my $self = shift;
+
+ if (@_) {
+ ${ $self->{$slot} } = shift;
+ }
+
+ return ${ $self->{$slot} };
+ };
+
+ *{"append_to_$slot"} = sub {
+ my $self = shift;
+ my $s = shift;
+
+ return $self->$slot($self->$slot . $s);
+ };
+ }
+}
+
+sub _DB_on_init__initialize_globals
+{
+ my $self = shift;
+
+ # Check for whether we should be running continuously or not.
+ # _After_ the perl program is compiled, $single is set to 1:
+ if ( $single and not $second_time++ ) {
+
+ # Options say run non-stop. Run until we get an interrupt.
+ if ($runnonstop) { # Disable until signal
+ # If there's any call stack in place, turn off single
+ # stepping into subs throughout the stack.
+ for my $i (0 .. $stack_depth) {
+ $stack[ $i ] &= ~1;
+ }
+
+ # And we are now no longer in single-step mode.
+ $single = 0;
+
+ # If we simply returned at this point, we wouldn't get
+ # the trace info. Fall on through.
+ # return;
+ } ## end if ($runnonstop)
+
+ elsif ($ImmediateStop) {
+
+ # We are supposed to stop here; XXX probably a break.
+ $ImmediateStop = 0; # We've processed it; turn it off
+ $signal = 1; # Simulate an interrupt to force
+ # us into the command loop
+ }
+ } ## end if ($single and not $second_time...
+
+ # If we're in single-step mode, or an interrupt (real or fake)
+ # has occurred, turn off non-stop mode.
+ $runnonstop = 0 if $single or $signal;
+
+ return;
+}
+
+sub _my_print_lineinfo
+{
+ my ($self, $i, $incr_pos) = @_;
+
+ if ($frame) {
+
+ # Print it indented if tracing is on.
+ DB::print_lineinfo( ' ' x $stack_depth,
+ "$i:\t$DB::dbline[$i]" . $self->after );
+ }
+ else {
+ DB::depth_print_lineinfo($self->explicit_stop, $incr_pos);
+ }
+}
+
+sub _curr_line {
+ return $DB::dbline[$line];
+}
+
+sub _is_full {
+ my ($self, $letter) = @_;
+
+ return ($DB::cmd eq $letter);
+}
+
+sub _DB__grab_control
+{
+ my $self = shift;
+
+ # Yes, grab control.
+ if ($slave_editor) {
+
+ # Tell the editor to update its position.
+ $self->position("\032\032${DB::filename}:$line:0\n");
+ DB::print_lineinfo($self->position());
+ }
+
+=pod
+
+Special check: if we're in package C<DB::fake>, we've gone through the
+C<END> block at least once. We set up everything so that we can continue
+to enter commands and have a valid context to be in.
+
+=cut
+
+ elsif ( $DB::package eq 'DB::fake' ) {
+
+ # Fallen off the end already.
+ if (!$DB::term) {
+ DB::setterm();
+ }
+
+# DB::print_help(<<EOP);
+#Debugged program terminated. Use B<q> to quit or B<R> to restart,
+#use B<o> I<inhibit_exit> to avoid stopping after program termination,
+#B<h q>, B<h R> or B<h o> to get additional info.
+#EOP
+
+ # Set the DB::eval context appropriately.
+ $DB::package = 'main';
+ $DB::usercontext = DB::_calc_usercontext($DB::package);
+ } ## end elsif ($package eq 'DB::fake')
+
+=pod
+
+If the program hasn't finished executing, we scan forward to the
+next executable line, print that out, build the prompt from the file and line
+number information, and print that.
+
+=cut
+
+ else {
+
+
+ # Still somewhere in the midst of execution. Set up the
+ # debugger prompt.
+ $DB::sub =~ s/\'/::/; # Swap Perl 4 package separators (') to
+ # Perl 5 ones (sorry, we don't print Klingon
+ #module names)
+
+ $self->prefix($DB::sub =~ /::/ ? "" : ($DB::package . '::'));
+ $self->append_to_prefix( "$DB::sub(${DB::filename}:" );
+ $self->after( $self->_curr_line =~ /\n$/ ? '' : "\n" );
+
+ # Break up the prompt if it's really long.
+ if ( length($self->prefix()) > 30 ) {
+ $self->position($self->prefix . "$line):\n$line:\t" . $self->_curr_line . $self->after);
+ $self->prefix("");
+ $self->infix(":\t");
+ }
+ else {
+ $self->infix("):\t");
+ $self->position(
+ $self->prefix . $line. $self->infix
+ . $self->_curr_line . $self->after
+ );
+ }
+
+ # Print current line info, indenting if necessary.
+ # $self->_my_print_lineinfo($line, $self->position);
+ #
+ my $myfile = $DB::filename;
+ unless (dbutil::isexludedpath($myfile)){
+ print "\r\n{\"command\": \"paused\", \"file\": \"$myfile\", \"line\": $line}\r\n";
+ }else{
+ print "*** ignore: $myfile\r\n";
+ }
+
+ my $i;
+ my $line_i = sub { return $DB::dbline[$i]; };
+
+ # Scan forward, stopping at either the end or the next
+ # unbreakable line.
+ for ( $i = $line + 1 ; $i <= $DB::max && $line_i->() == 0 ; ++$i )
+ { #{ vi
+
+ # Drop out on null statements, block closers, and comments.
+ last if $line_i->() =~ /^\s*[\;\}\#\n]/;
+
+ # Drop out if the user interrupted us.
+ last if $signal;
+
+ # Append a newline if the line doesn't have one. Can happen
+ # in eval'ed text, for instance.
+ $self->after( $line_i->() =~ /\n$/ ? '' : "\n" );
+
+ # Next executable line.
+ my $incr_pos = $self->prefix . $i . $self->infix . $line_i->()
+ . $self->after;
+ $self->append_to_position($incr_pos);
+
+ # $self->_my_print_lineinfo($i, $incr_pos);
+
+ # print "{\"command\": \"paused\", \"file\": \"$myfile\", \"line\": $i}\r\n";
+
+
+ } ## end for ($i = $line + 1 ; $i...
+
+ } ## end else [ if ($slave_editor)
+
+ return;
+}
+
+sub _handle_t_command {
+ my $self = shift;
+
+ my $levels = $self->cmd_args();
+
+ if ((!length($levels)) or ($levels !~ /\D/)) {
+ $trace ^= 1;
+ local $\ = '';
+ $DB::trace_to_depth = $levels ? $stack_depth + $levels : 1E9;
+ print {$OUT} "Trace = "
+ . ( ( $trace & 1 )
+ ? ( $levels ? "on (to level $DB::trace_to_depth)" : "on" )
+ : "off" ) . "\r\n";
+ next CMD;
+ }
+
+ return;
+}
+
+
+sub _handle_S_command {
+ my $self = shift;
+
+ if (my ($print_all_subs, $should_reverse, $Spatt)
+ = $self->cmd_args =~ /\A((!)?(.+))?\z/) {
+ # $Spatt is the pattern (if any) to use.
+ # Reverse scan?
+ my $Srev = defined $should_reverse;
+ # No args - print all subs.
+ my $Snocheck = !defined $print_all_subs;
+
+ # Need to make these sane here.
+ local $\ = '';
+ local $, = '';
+
+ # Search through the debugger's magical hash of subs.
+ # If $nocheck is true, just print the sub name.
+ # Otherwise, check it against the pattern. We then use
+ # the XOR trick to reverse the condition as required.
+ foreach $subname ( sort( keys %sub ) ) {
+ if ( $Snocheck or $Srev ^ ( $subname =~ /$Spatt/ ) ) {
+ print $OUT $subname, "\n";
+ }
+ }
+ print $OUT "\r\n";
+ next CMD;
+ }
+
+ return;
+}
+
+sub _handle_V_command_and_X_command {
+ my $self = shift;
+
+ $DB::cmd =~ s/^X\b/V $DB::package/;
+
+ # Bare V commands get the currently-being-debugged package
+ # added.
+ if ($self->_is_full('V')) {
+ $DB::cmd = "V $DB::package";
+ }
+
+ # V - show variables in package.
+ if (my ($new_packname, $new_vars_str) =
+ $DB::cmd =~ /\AV\b\s*(\S+)\s*(.*)/) {
+
+ # Save the currently selected filehandle and
+ # force output to debugger's filehandle (dumpvar
+ # just does "print" for output).
+ my $savout = select($OUT);
+
+ # Grab package name and variables to dump.
+ $packname = $new_packname;
+ my @vars = split( ' ', $new_vars_str );
+
+ # If main::dumpvar isn't here, get it.
+ do 'dumpvar.pl' || dir $@ unless defined &main::dumpvar;
+ if ( defined &main::dumpvar ) {
+
+ # We got it. Turn off subroutine entry/exit messages
+ # for the moment, along with return values.
+ local $frame = 0;
+ local $doret = -2;
+
+ # must detect sigpipe failures - not catching
+ # then will cause the debugger to die.
+ eval {
+ main::dumpvar(
+ $packname,
+ defined $option{dumpDepth}
+ ? $option{dumpDepth}
+ : -1, # assume -1 unless specified
+ @vars
+ );
+ };
+
+ # The die doesn't need to include the $@, because
+ # it will automatically get propagated for us.
+ if ($@) {
+ die unless $@ =~ /dumpvar print failed/;
+ }
+ } ## end if (defined &main::dumpvar)
+ else {
+
+ # Couldn't load dumpvar.
+ print $OUT "dumpvar.pl not available.\r\n";
+ }
+
+ # Restore the output filehandle, and go round again.
+ select($savout);
+ next CMD;
+ }
+
+ return;
+}
+
+sub _handle_dash_command {
+ my $self = shift;
+
+ if ($self->_is_full('-')) {
+
+ # back up by a window; go to 1 if back too far.
+ $start -= $incr + $window + 1;
+ $start = 1 if $start <= 0;
+ $incr = $window - 1;
+
+ # Generate and execute a "l +" command (handled below).
+ $DB::cmd = 'l ' . ($start) . '+';
+ redo CMD;
+ }
+ return;
+}
+
+sub _n_or_s_commands_generic {
+ my ($self, $new_val) = @_;
+ # n - next
+ next CMD if DB::_DB__is_finished();
+
+ # Single step, but don't enter subs.
+ $single = $new_val;
+
+ # Save for empty command (repeat last).
+ $laststep = $DB::cmd;
+ last CMD;
+}
+
+sub _n_or_s {
+ my ($self, $letter, $new_val) = @_;
+
+ if ($self->_is_full($letter)) {
+ $self->_n_or_s_commands_generic($new_val);
+ }
+ else {
+ $self->_n_or_s_and_arg_commands_generic($letter, $new_val);
+ }
+
+ return;
+}
+
+sub _handle_n_command {
+ my $self = shift;
+
+ return $self->_n_or_s('n', 2);
+}
+
+sub _handle_s_command {
+ my $self = shift;
+
+ return if $DB::filename eq "perl5db.pl";
+
+ return $self->_n_or_s('s', 1);
+}
+
+sub _handle_r_command {
+ my $self = shift;
+
+ # r - return from the current subroutine.
+ if ($self->_is_full('r')) {
+
+ # Can't do anything if the program's over.
+ next CMD if DB::_DB__is_finished();
+
+ # Turn on stack trace.
+ $stack[$stack_depth] |= 1;
+
+ # Print return value unless the stack is empty.
+ $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
+ last CMD;
+ }
+
+ return;
+}
+
+sub _handle_T_command {
+ my $self = shift;
+
+ if ($self->_is_full('T')) {
+ DB::print_trace( $OUT, 1 ); # skip DB
+ next CMD;
+ }
+
+ return;
+}
+
+sub _handle_w_command {
+ my $self = shift;
+
+ DB::cmd_w( 'w', $self->cmd_args() );
+ next CMD;
+
+ return;
+}
+
+sub _handle_W_command {
+ my $self = shift;
+
+ if (my $arg = $self->cmd_args) {
+ DB::cmd_W( 'W', $arg );
+ next CMD;
+ }
+
+ return;
+}
+
+sub _handle_rc_recall_command {
+ my $self = shift;
+
+ # $rc - recall command.
+ if (my ($minus, $arg) = $DB::cmd =~ m#\A$rc+\s*(-)?(\d+)?\z#) {
+
+ # No arguments, take one thing off history.
+ pop(@hist) if length($DB::cmd) > 1;
+
+ # Relative (- found)?
+ # Y - index back from most recent (by 1 if bare minus)
+ # N - go to that particular command slot or the last
+ # thing if nothing following.
+
+ $self->cmd_verb(
+ scalar($minus ? ( $#hist - ( $arg || 1 ) ) : ( $arg || $#hist ))
+ );
+
+ # Pick out the command desired.
+ $DB::cmd = $hist[$self->cmd_verb];
+
+ # Print the command to be executed and restart the loop
+ # with that command in the buffer.
+ print {$OUT} $DB::cmd, "\r\n";
+ redo CMD;
+ }
+
+ return;
+}
+
+sub _handle_rc_search_history_command {
+ my $self = shift;
+
+ # $rc pattern $rc - find a command in the history.
+ if (my ($arg) = $DB::cmd =~ /\A$rc([^$rc].*)\z/) {
+
+ # Create the pattern to use.
+ my $pat = "^$arg";
+ $self->pat($pat);
+
+ # Toss off last entry if length is >1 (and it always is).
+ pop(@hist) if length($DB::cmd) > 1;
+
+ my $i;
+
+ # Look backward through the history.
+ SEARCH_HIST:
+ for ( $i = $#hist ; $i ; --$i ) {
+ # Stop if we find it.
+ last SEARCH_HIST if $hist[$i] =~ /$pat/;
+ }
+
+ if ( !$i ) {
+
+ # Never found it.
+ print $OUT "No such command!\r\n";
+ next CMD;
+ }
+
+ # Found it. Put it in the buffer, print it, and process it.
+ $DB::cmd = $hist[$i];
+ print $OUT $DB::cmd, "\r\n";
+ redo CMD;
+ }
+
+ return;
+}
+
+sub _handle_H_command {
+ my $self = shift;
+
+ if ($self->cmd_args =~ m#\A\*#) {
+ @hist = @truehist = ();
+ print $OUT "History cleansed\r\n";
+ next CMD;
+ }
+
+ if (my ($num) = $self->cmd_args =~ /\A(?:-(\d+))?/) {
+
+ # Anything other than negative numbers is ignored by
+ # the (incorrect) pattern, so this test does nothing.
+ $end = $num ? ( $#hist - $num ) : 0;
+
+ # Set to the minimum if less than zero.
+ $hist = 0 if $hist < 0;
+
+ # Start at the end of the array.
+ # Stay in while we're still above the ending value.
+ # Tick back by one each time around the loop.
+ my $i;
+
+ for ( $i = $#hist ; $i > $end ; $i-- ) {
+
+ # Print the command unless it has no arguments.
+ print $OUT "$i: ", $hist[$i], "\n"
+ unless $hist[$i] =~ /^.?$/;
+ }
+ print $OUT "\r\n";
+
+ next CMD;
+ }
+
+ return;
+}
+
+sub _handle_doc_command {
+ my $self = shift;
+
+ # man, perldoc, doc - show manual pages.
+ if (my ($man_page)
+ = $DB::cmd =~ /\A(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?\z/) {
+ DB::runman($man_page);
+ next CMD;
+ }
+
+ return;
+}
+
+sub _handle_p_command {
+ my $self = shift;
+
+ my $print_cmd = 'print {$DB::OUT} ';
+ # p - print (no args): print $_.
+ if ($self->_is_full('p')) {
+ $DB::cmd = $print_cmd . '$_';
+ }
+ else {
+ # p - print the given expression.
+ $DB::cmd =~ s/\Ap\b/$print_cmd /;
+ }
+
+ return;
+}
+
+sub _handle_equal_sign_command {
+ my $self = shift;
+
+ if ($DB::cmd =~ s/\A=\s*//) {
+ my @keys;
+ if ( length $DB::cmd == 0 ) {
+
+ # No args, get current aliases.
+ @keys = sort keys %alias;
+ }
+ elsif ( my ( $k, $v ) = ( $DB::cmd =~ /^(\S+)\s+(\S.*)/ ) ) {
+
+ # Creating a new alias. $k is alias name, $v is
+ # alias value.
+
+ # can't use $_ or kill //g state
+ for my $x ( $k, $v ) {
+
+ # Escape "alarm" characters.
+ $x =~ s/\a/\\a/g;
+ }
+
+ # Substitute key for value, using alarm chars
+ # as separators (which is why we escaped them in
+ # the command).
+ $alias{$k} = "s\a$k\a$v\a";
+
+ # Turn off standard warn and die behavior.
+ local $SIG{__DIE__};
+ local $SIG{__WARN__};
+
+ # Is it valid Perl?
+ unless ( eval "sub { s\a$k\a$v\a }; 1" ) {
+
+ # Nope. Bad alias. Say so and get out.
+ print $OUT "Can't alias $k to $v: $@\r\n";
+ delete $alias{$k};
+ next CMD;
+ }
+
+ # We'll only list the new one.
+ @keys = ($k);
+ } ## end elsif (my ($k, $v) = ($DB::cmd...
+
+ # The argument is the alias to list.
+ else {
+ @keys = ($DB::cmd);
+ }
+
+ # List aliases.
+ for my $k (@keys) {
+
+ # Messy metaquoting: Trim the substitution code off.
+ # We use control-G as the delimiter because it's not
+ # likely to appear in the alias.
+ if ( ( my $v = $alias{$k} ) =~ s\as\a$k\a(.*)\a$\a1\a ) {
+
+ # Print the alias.
+ print $OUT "$k\t= $1\n";
+ }
+ elsif ( defined $alias{$k} ) {
+
+ # Couldn't trim it off; just print the alias code.
+ print $OUT "$k\t$alias{$k}\n";
+ }
+ else {
+
+ # No such, dude.
+ print "No alias for $k\n";
+ }
+ } ## end for my $k (@keys)
+ print $OUT "\r\n";
+
+ next CMD;
+ }
+
+ return;
+}
+
+sub _handle_source_command {
+ my $self = shift;
+
+ # source - read commands from a file (or pipe!) and execute.
+ if (my $sourced_fn = $self->cmd_args) {
+ if ( open my $fh, $sourced_fn ) {
+
+ # Opened OK; stick it in the list of file handles.
+ push @cmdfhs, $fh;
+ }
+ else {
+
+ # Couldn't open it.
+ DB::_db_warn("Can't execute '$sourced_fn': $!\n");
+ }
+ next CMD;
+ }
+
+ return;
+}
+
+sub _handle_enable_disable_commands {
+ my $self = shift;
+
+ my $which_cmd = $self->cmd_verb;
+ my $position = $self->cmd_args;
+
+ if ($position !~ /\s/) {
+ my ($fn, $line_num);
+ if ($position =~ m{\A\d+\z})
+ {
+ $fn = $DB::filename;
+ $line_num = $position;
+ }
+ elsif (my ($new_fn, $new_line_num)
+ = $position =~ m{\A(.*):(\d+)\z}) {
+ ($fn, $line_num) = ($new_fn, $new_line_num);
+ }
+ else
+ {
+ DB::_db_warn("Wrong spec for enable/disable argument.\r\n");
+ }
+
+ if (defined($fn)) {
+ if (DB::_has_breakpoint_data_ref($fn, $line_num)) {
+ DB::_set_breakpoint_enabled_status($fn, $line_num,
+ ($which_cmd eq 'enable' ? 1 : '')
+ );
+ }
+ else {
+ DB::_db_warn("No breakpoint set at ${fn}:${line_num}\r\n");
+ }
+ }
+
+ next CMD;
+ }
+
+ return;
+}
+
+sub _handle_save_command {
+ my $self = shift;
+
+ if (my $new_fn = $self->cmd_args) {
+ my $filename = $new_fn || '.perl5dbrc'; # default?
+ if ( open my $fh, '>', $filename ) {
+
+ # chomp to remove extraneous newlines from source'd files
+ chomp( my @truelist =
+ map { m/\A\s*(save|source)/ ? "#$_" : $_ }
+ @truehist );
+ print {$fh} join( "\n", @truelist );
+ print "commands saved in $filename\r\n";
+ }
+ else {
+ DB::_db_warn("Can't save debugger commands in '$new_fn': $!\r\n");
+ }
+ next CMD;
+ }
+
+ return;
+}
+
+sub _n_or_s_and_arg_commands_generic {
+ my ($self, $letter, $new_val) = @_;
+
+ # s - single-step. Remember the last command was 's'.
+ if ($DB::cmd =~ s#\A\Q$letter\E\s#\$DB::single = $new_val;\n#) {
+ $laststep = $letter;
+ }
+
+ return;
+}
+
+sub _handle_sh_command {
+ my $self = shift;
+
+ # $sh$sh - run a shell command (if it's all ASCII).
+ # Can't run shell commands with Unicode in the debugger, hmm.
+ my $my_cmd = $DB::cmd;
+ if ($my_cmd =~ m#\A$sh#gms) {
+
+ if ($my_cmd =~ m#\G\z#cgms) {
+ # Run the user's shell. If none defined, run Bourne.
+ # We resume execution when the shell terminates.
+ DB::_db_system( $ENV{SHELL} || "/bin/sh" );
+ next CMD;
+ }
+ elsif ($my_cmd =~ m#\G$sh\s*(.*)#cgms) {
+ # System it.
+ DB::_db_system($1);
+ next CMD;
+ }
+ elsif ($my_cmd =~ m#\G\s*(.*)#cgms) {
+ DB::_db_system( $ENV{SHELL} || "/bin/sh", "-c", $1 );
+ next CMD;
+ }
+ }
+}
+
+sub _handle_x_command {
+ my $self = shift;
+
+ if ($DB::cmd =~ s#\Ax\b# #) { # Remainder gets done by DB::eval()
+ $onetimeDump = 'dump'; # main::dumpvar shows the output
+
+ # handle special "x 3 blah" syntax XXX propagate
+ # doc back to special variables.
+ if ( $DB::cmd =~ s#\A\s*(\d+)(?=\s)# #) {
+ $onetimedumpDepth = $1;
+ }
+ }
+
+ return;
+}
+
+sub _handle_q_command {
+ my $self = shift;
+
+ if ($self->_is_full('q')) {
+ $fall_off_end = 1;
+ DB::clean_ENV();
+ end_report();
+ exit $?;
+ }
+
+ return;
+}
+
+sub _handle_cmd_wrapper_commands {
+ my $self = shift;
+
+ DB::cmd_wrapper( $self->cmd_verb, $self->cmd_args, $line );
+ next CMD;
+}
+
+sub _handle_special_char_cmd_wrapper_commands {
+ my $self = shift;
+
+ # All of these commands were remapped in perl 5.8.0;
+ # we send them off to the secondary dispatcher (see below).
+ if (my ($cmd_letter, $my_arg) = $DB::cmd =~ /\A([<>\{]{1,2})\s*(.*)/so) {
+ DB::cmd_wrapper( $cmd_letter, $my_arg, $line );
+ next CMD;
+ }
+
+ return;
+}
+
+} ## end DB::Obj
+
+package DB;
+
+# The following code may be executed now:
+# BEGIN {warn 4}
+
+=head2 sub
+
+C<sub> is called whenever a subroutine call happens in the program being
+debugged. The variable C<$DB::sub> contains the name of the subroutine
+being called.
+
+The core function of this subroutine is to actually call the sub in the proper
+context, capturing its output. This of course causes C<DB::DB> to get called
+again, repeating until the subroutine ends and returns control to C<DB::sub>
+again. Once control returns, C<DB::sub> figures out whether or not to dump the
+return value, and returns its captured copy of the return value as its own
+return value. The value then feeds back into the program being debugged as if
+C<DB::sub> hadn't been there at all.
+
+C<sub> does all the work of printing the subroutine entry and exit messages
+enabled by setting C<$frame>. It notes what sub the autoloader got called for,
+and also prints the return value if needed (for the C<r> command and if
+the 16 bit is set in C<$frame>).
+
+It also tracks the subroutine call depth by saving the current setting of
+C<$single> in the C<@stack> package global; if this exceeds the value in
+C<$deep>, C<sub> automatically turns on printing of the current depth by
+setting the C<4> bit in C<$single>. In any case, it keeps the current setting
+of stop/don't stop on entry to subs set as it currently is set.
+
+=head3 C<caller()> support
+
+If C<caller()> is called from the package C<DB>, it provides some
+additional data, in the following order:
+
+=over 4
+
+=item * C<$package>
+
+The package name the sub was in
+
+=item * C<$filename>
+
+The filename it was defined in
+
+=item * C<$line>
+
+The line number it was defined on
+
+=item * C<$subroutine>
+
+The subroutine name; C<(eval)> if an C<eval>().
+
+=item * C<$hasargs>
+
+1 if it has arguments, 0 if not
+
+=item * C<$wantarray>
+
+1 if array context, 0 if scalar context
+
+=item * C<$evaltext>
+
+The C<eval>() text, if any (undefined for C<eval BLOCK>)
+
+=item * C<$is_require>
+
+frame was created by a C<use> or C<require> statement
+
+=item * C<$hints>
+
+pragma information; subject to change between versions
+
+=item * C<$bitmask>
+
+pragma information; subject to change between versions
+
+=item * C<@DB::args>
+
+arguments with which the subroutine was invoked
+
+=back
+
+=cut
+
+use vars qw($deep);
+
+# We need to fully qualify the name ("DB::sub") to make "use strict;"
+# happy. -- Shlomi Fish
+
+sub _indent_print_line_info {
+ my ($offset, $str) = @_;
+
+ print_lineinfo( ' ' x ($stack_depth - $offset), $str);
+
+ return;
+}
+
+sub _print_frame_message {
+ my ($al) = @_;
+
+ if ($frame) {
+ if ($frame & 4) { # Extended frame entry message
+ # _indent_print_line_info(-1, "in "); #removed this indent!!
+
+ # Why -1? But it works! :-(
+ # Because print_trace will call add 1 to it and then call
+ # dump_trace; this results in our skipping -1+1 = 0 stack frames
+ # in dump_trace.
+ #
+ # Now it's 0 because we extracted a function.
+ print_trace( $LINEINFO, 0, 1, 1, "$sub$al" );
+ }
+ else {
+ _indent_print_line_info(-1, "entering $sub$al\r\n" );
+ }
+ }
+
+ return;
+}
+
+sub DB::sub {
+ # Do not use a regex in this subroutine -> results in corrupted memory
+ # See: [perl #66110]
+
+ # lock ourselves under threads
+ lock($DBGR);
+
+ # Whether or not the autoloader was running, a scalar to put the
+ # sub's return value in (if needed), and an array to put the sub's
+ # return value in (if needed).
+ my ( $al, $ret, @ret ) = "";
+ if ($sub eq 'threads::new' && $ENV{PERL5DB_THREADED}) {
+ print "creating new thread\r\n";
+ }
+
+ # If the last ten characters are '::AUTOLOAD', note we've traced
+ # into AUTOLOAD for $sub.
+ if ( length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) {
+ no strict 'refs';
+ $al = " for $$sub" if defined $$sub;
+ }
+
+ # We stack the stack pointer and then increment it to protect us
+ # from a situation that might unwind a whole bunch of call frames
+ # at once. Localizing the stack pointer means that it will automatically
+ # unwind the same amount when multiple stack frames are unwound.
+ local $stack_depth = $stack_depth + 1; # Protect from non-local exits
+
+ # Expand @stack.
+ $#stack = $stack_depth;
+
+ # Save current single-step setting.
+ $stack[-1] = $single;
+
+ # Turn off all flags except single-stepping.
+ $single &= 1;
+
+ # If we've gotten really deeply recursed, turn on the flag that will
+ # make us stop with the 'deep recursion' message.
+ $single |= 4 if $stack_depth == $deep;
+
+ # If frame messages are on ...
+
+ _print_frame_message($al);
+ # standard frame entry message
+
+ my $print_exit_msg = sub {
+ # Check for exit trace messages...
+ if ($frame & 2)
+ {
+ if ($frame & 4) # Extended exit message
+ {
+ _indent_print_line_info(0, "out ");
+ print_trace( $LINEINFO, 0, 1, 1, "$sub$al" );
+ }
+ else
+ {
+ _indent_print_line_info(0, "exited $sub$al\r\n" );
+ }
+ }
+ return;
+ };
+
+ # Determine the sub's return type, and capture appropriately.
+ if (wantarray) {
+
+ # Called in array context. call sub and capture output.
+ # DB::DB will recursively get control again if appropriate; we'll come
+ # back here when the sub is finished.
+ {
+ no strict 'refs';
+ @ret = &$sub;
+ }
+
+ # Pop the single-step value back off the stack.
+ $single |= $stack[ $stack_depth-- ];
+
+ $print_exit_msg->();
+
+ # Print the return info if we need to.
+ if ( $doret eq $stack_depth or $frame & 16 ) {
+
+ # Turn off output record separator.
+ local $\ = '';
+ my $fh = ( $doret eq $stack_depth ? $OUT : $LINEINFO );
+
+ # Indent if we're printing because of $frame tracing.
+ if ($frame & 16)
+ {
+ print {$fh} ' ' x $stack_depth;
+ }
+
+ # Print the return value.
+ print {$fh} "list context return from $sub:\r\n";
+ dumpit( $fh, \@ret );
+
+ # And don't print it again.
+ $doret = -2;
+ } ## end if ($doret eq $stack_depth...
+ # And we have to return the return value now.
+ @ret;
+ } ## end if (wantarray)
+
+ # Scalar context.
+ else {
+ if ( defined wantarray ) {
+ no strict 'refs';
+ # Save the value if it's wanted at all.
+ $ret = &$sub;
+ }
+ else {
+ no strict 'refs';
+ # Void return, explicitly.
+ &$sub;
+ undef $ret;
+ }
+
+ # Pop the single-step value off the stack.
+ $single |= $stack[ $stack_depth-- ];
+
+ # If we're doing exit messages...
+ $print_exit_msg->();
+
+ # If we are supposed to show the return value... same as before.
+ if ( $doret eq $stack_depth or $frame & 16 and defined wantarray ) {
+ local $\ = '';
+ my $fh = ( $doret eq $stack_depth ? $OUT : $LINEINFO );
+ print $fh ( ' ' x $stack_depth ) if $frame & 16;
+ print $fh (
+ defined wantarray
+ ? "scalar context return from $sub: "
+ : "void context return from $sub\r\n"
+ );
+ dumpit( $fh, $ret ) if defined wantarray;
+ $doret = -2;
+ } ## end if ($doret eq $stack_depth...
+
+ # Return the appropriate scalar value.
+ $ret;
+ } ## end else [ if (wantarray)
+} ## end sub _sub
+
+sub lsub : lvalue {
+
+ no strict 'refs';
+
+ # lock ourselves under threads
+ lock($DBGR);
+
+ # Whether or not the autoloader was running, a scalar to put the
+ # sub's return value in (if needed), and an array to put the sub's
+ # return value in (if needed).
+ my ( $al, $ret, @ret ) = "";
+ if ($sub =~ /^threads::new$/ && $ENV{PERL5DB_THREADED}) {
+ print "creating new thread\r\n";
+ }
+
+ # If the last ten characters are C'::AUTOLOAD', note we've traced
+ # into AUTOLOAD for $sub.
+ if ( length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) {
+ $al = " for $$sub";
+ }
+
+ # We stack the stack pointer and then increment it to protect us
+ # from a situation that might unwind a whole bunch of call frames
+ # at once. Localizing the stack pointer means that it will automatically
+ # unwind the same amount when multiple stack frames are unwound.
+ local $stack_depth = $stack_depth + 1; # Protect from non-local exits
+
+ # Expand @stack.
+ $#stack = $stack_depth;
+
+ # Save current single-step setting.
+ $stack[-1] = $single;
+
+ # Turn off all flags except single-stepping.
+ $single &= 1;
+
+ # If we've gotten really deeply recursed, turn on the flag that will
+ # make us stop with the 'deep recursion' message.
+ $single |= 4 if $stack_depth == $deep;
+
+ # If frame messages are on ...
+ _print_frame_message($al);
+
+ # Pop the single-step value back off the stack.
+ $single |= $stack[ $stack_depth-- ];
+
+ # call the original lvalue sub.
+ &$sub;
+}
+
+# Abstracting common code from multiple places elsewhere:
+sub depth_print_lineinfo {
+ my $always_print = shift;
+
+ print_lineinfo( @_ ) if ($always_print or $stack_depth < $trace_to_depth);
+}
+
+=head1 EXTENDED COMMAND HANDLING AND THE COMMAND API
+
+In Perl 5.8.0, there was a major realignment of the commands and what they did,
+Most of the changes were to systematize the command structure and to eliminate
+commands that threw away user input without checking.
+
+The following sections describe the code added to make it easy to support
+multiple command sets with conflicting command names. This section is a start
+at unifying all command processing to make it simpler to develop commands.
+
+Note that all the cmd_[a-zA-Z] subroutines require the command name, a line
+number, and C<$dbline> (the current line) as arguments.
+
+Support functions in this section which have multiple modes of failure C<die>
+on error; the rest simply return a false value.
+
+The user-interface functions (all of the C<cmd_*> functions) just output
+error messages.
+
+=head2 C<%set>
+
+The C<%set> hash defines the mapping from command letter to subroutine
+name suffix.
+
+C<%set> is a two-level hash, indexed by set name and then by command name.
+Note that trying to set the CommandSet to C<foobar> simply results in the
+5.8.0 command set being used, since there's no top-level entry for C<foobar>.
+
+=cut
+
+### The API section
+
+my %set = ( #
+ 'pre580' => {
+ 'a' => 'pre580_a',
+ 'A' => 'pre580_null',
+ 'b' => 'pre580_b',
+ 'B' => 'pre580_null',
+ 'd' => 'pre580_null',
+ 'D' => 'pre580_D',
+ 'h' => 'pre580_h',
+ 'M' => 'pre580_null',
+ 'O' => 'o',
+ 'o' => 'pre580_null',
+ 'v' => 'M',
+ 'w' => 'v',
+ 'W' => 'pre580_W',
+ },
+ 'pre590' => {
+ '<' => 'pre590_prepost',
+ '<<' => 'pre590_prepost',
+ '>' => 'pre590_prepost',
+ '>>' => 'pre590_prepost',
+ '{' => 'pre590_prepost',
+ '{{' => 'pre590_prepost',
+ },
+);
+
+my %breakpoints_data;
+
+sub _has_breakpoint_data_ref {
+ my ($filename, $line) = @_;
+
+ return (
+ exists( $breakpoints_data{$filename} )
+ and
+ exists( $breakpoints_data{$filename}{$line} )
+ );
+}
+
+sub _get_breakpoint_data_ref {
+ my ($filename, $line) = @_;
+
+ return ($breakpoints_data{$filename}{$line} ||= +{});
+}
+
+sub _delete_breakpoint_data_ref {
+ my ($filename, $line) = @_;
+
+ delete($breakpoints_data{$filename}{$line});
+ if (! scalar(keys( %{$breakpoints_data{$filename}} )) ) {
+ delete($breakpoints_data{$filename});
+ }
+
+ return;
+}
+
+sub _set_breakpoint_enabled_status {
+ my ($filename, $line, $status) = @_;
+
+ _get_breakpoint_data_ref($filename, $line)->{'enabled'} =
+ ($status ? 1 : '')
+ ;
+
+ return;
+}
+
+sub _enable_breakpoint_temp_enabled_status {
+ my ($filename, $line) = @_;
+
+ _get_breakpoint_data_ref($filename, $line)->{'temp_enabled'} = 1;
+
+ return;
+}
+
+sub _cancel_breakpoint_temp_enabled_status {
+ my ($filename, $line) = @_;
+
+ my $ref = _get_breakpoint_data_ref($filename, $line);
+
+ delete ($ref->{'temp_enabled'});
+
+ if (! %$ref) {
+ _delete_breakpoint_data_ref($filename, $line);
+ }
+
+ return;
+}
+
+sub _is_breakpoint_enabled {
+ my ($filename, $line) = @_;
+
+ my $data_ref = _get_breakpoint_data_ref($filename, $line);
+ return ($data_ref->{'enabled'} || $data_ref->{'temp_enabled'});
+}
+
+=head2 C<cmd_wrapper()> (API)
+
+C<cmd_wrapper()> allows the debugger to switch command sets
+depending on the value of the C<CommandSet> option.
+
+It tries to look up the command in the C<%set> package-level I<lexical>
+(which means external entities can't fiddle with it) and create the name of
+the sub to call based on the value found in the hash (if it's there). I<All>
+of the commands to be handled in a set have to be added to C<%set>; if they
+aren't found, the 5.8.0 equivalent is called (if there is one).
+
+This code uses symbolic references.
+
+=cut
+
+sub cmd_wrapper {
+ my $cmd = shift;
+ my $line = shift;
+ my $dblineno = shift;
+
+ # Assemble the command subroutine's name by looking up the
+ # command set and command name in %set. If we can't find it,
+ # default to the older version of the command.
+ my $call = 'cmd_'
+ . ( $set{$CommandSet}{$cmd}
+ || ( $cmd =~ /\A[<>{]+/o ? 'prepost' : $cmd ) );
+
+ # Call the command subroutine, call it by name.
+ return __PACKAGE__->can($call)->( $cmd, $line, $dblineno );
+} ## end sub cmd_wrapper
+
+=head3 C<cmd_a> (command)
+
+The C<a> command handles pre-execution actions. These are associated with a
+particular line, so they're stored in C<%dbline>. We default to the current
+line if none is specified.
+
+=cut
+
+sub cmd_a {
+ my $cmd = shift;
+ my $line = shift || ''; # [.|line] expr
+ my $dbline = shift;
+
+ # If it's dot (here), or not all digits, use the current line.
+ $line =~ s/\A\./$dbline/;
+
+ # Should be a line number followed by an expression.
+ if ( my ($lineno, $expr) = $line =~ /^\s*(\d*)\s*(\S.+)/ ) {
+
+ if (! length($lineno)) {
+ $lineno = $dbline;
+ }
+
+ # If we have an expression ...
+ if ( length $expr ) {
+
+ # ... but the line isn't breakable, complain.
+ if ( $dbline[$lineno] == 0 ) {
+ print $OUT
+ "Line $lineno($dbline[$lineno]) does not have an action?\r\n";
+ }
+ else {
+
+ # It's executable. Record that the line has an action.
+ $had_breakpoints{$filename} |= 2;
+
+ # Remove any action, temp breakpoint, etc.
+ $dbline{$lineno} =~ s/\0[^\0]*//;
+
+ # Add the action to the line.
+ $dbline{$lineno} .= "\0" . action($expr);
+
+ _set_breakpoint_enabled_status($filename, $lineno, 1);
+ }
+ } ## end if (length $expr)
+ } ## end if ($line =~ /^\s*(\d*)\s*(\S.+)/)
+ else {
+
+ # Syntax wrong.
+ print $OUT
+ "Adding an action requires an optional lineno and an expression\r\n"
+ ; # hint
+ }
+} ## end sub cmd_a
+
+=head3 C<cmd_A> (command)
+
+Delete actions. Similar to above, except the delete code is in a separate
+subroutine, C<delete_action>.
+
+=cut
+
+sub cmd_A {
+ my $cmd = shift;
+ my $line = shift || '';
+ my $dbline = shift;
+
+ # Dot is this line.
+ $line =~ s/^\./$dbline/;
+
+ # Call delete_action with a null param to delete them all.
+ # The '1' forces the eval to be true. It'll be false only
+ # if delete_action blows up for some reason, in which case
+ # we print $@ and get out.
+ if ( $line eq '*' ) {
+ if (! eval { _delete_all_actions(); 1 }) {
+ print {$OUT} $@;
+ print {$OUT} "\r\n";
+ return;
+ }
+ }
+
+ # There's a real line number. Pass it to delete_action.
+ # Error trapping is as above.
+ elsif ( $line =~ /^(\S.*)/ ) {
+ if (! eval { delete_action($1); 1 }) {
+ print {$OUT} $@;
+ print {$OUT} "\r\n";
+ return;
+ }
+ }
+
+ # Swing and a miss. Bad syntax.
+ else {
+ print $OUT
+ "Deleting an action requires a line number, or '*' for all\r\n" ; # hint
+ }
+} ## end sub cmd_A
+
+=head3 C<delete_action> (API)
+
+C<delete_action> accepts either a line number or C<undef>. If a line number
+is specified, we check for the line being executable (if it's not, it
+couldn't have had an action). If it is, we just take the action off (this
+will get any kind of an action, including breakpoints).
+
+=cut
+
+sub _remove_action_from_dbline {
+ my $i = shift;
+
+ $dbline{$i} =~ s/\0[^\0]*//; # \^a
+ delete $dbline{$i} if $dbline{$i} eq '';
+
+ return;
+}
+
+
+sub _delete_all_actions {
+ print {$OUT} "Deleting all actions...\n";
+
+ for my $file ( keys %had_breakpoints ) {
+ local *dbline = $main::{ '_<' . $file };
+ $max = $#dbline;
+ my $was;
+ for my $i (1 .. $max) {
+ if ( defined $dbline{$i} ) {
+ _remove_action_from_dbline($i);
+ }
+ }
+
+ unless ( $had_breakpoints{$file} &= ~2 ) {
+ delete $had_breakpoints{$file};
+ }
+ }
+ print {$OUT} "end. \r\n";
+
+ return;
+}
+
+sub delete_action {
+ my $i = shift;
+
+ if ( defined($i) ) {
+ # Can there be one?
+ die "Line $i has no action .\n" if $dbline[$i] == 0;
+
+ # Nuke whatever's there.
+ _remove_action_from_dbline($i);
+ }
+ else {
+ _delete_all_actions();
+ }
+}
+
+=head3 C<cmd_b> (command)
+
+Set breakpoints. Since breakpoints can be set in so many places, in so many
+ways, conditionally or not, the breakpoint code is kind of complex. Mostly,
+we try to parse the command type, and then shuttle it off to an appropriate
+subroutine to actually do the work of setting the breakpoint in the right
+place.
+
+=cut
+
+sub cmd_b {
+ my $cmd = shift;
+ my $line = shift; # [.|line] [cond]
+ my $dbline = shift;
+
+ my $default_cond = sub {
+ my $cond = shift;
+ return length($cond) ? $cond : '1';
+ };
+
+ # Make . the current line number if it's there..
+ $line =~ s/^\.(\s|\z)/$dbline$1/;
+
+ # No line number, no condition. Simple break on current line.
+ if ( $line =~ /^\s*$/ ) {
+ cmd_b_line( $dbline, 1 );
+ }
+
+ # Break on load for a file.
+ elsif ( my ($file) = $line =~ /^load\b\s*(.*)/ ) {
+ $file =~ s/\s+\z//;
+ cmd_b_load($file);
+ }
+
+ # b compile|postpone <some sub> [<condition>]
+ # The interpreter actually traps this one for us; we just put the
+ # necessary condition in the %postponed hash.
+ elsif ( my ($action, $subname, $cond)
+ = $line =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ ) {
+
+ # De-Perl4-ify the name - ' separators to ::.
+ $subname =~ s/'/::/g;
+
+ # Qualify it into the current package unless it's already qualified.
+ $subname = "${package}::" . $subname unless $subname =~ /::/;
+
+ # Add main if it starts with ::.
+ $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::";
+
+ # Save the break type for this sub.
+ $postponed{$subname} = (($action eq 'postpone')
+ ? ( "break +0 if " . $default_cond->($cond) )
+ : "compile");
+ } ## end elsif ($line =~ ...
+ # b <filename>:<line> [<condition>]
+ elsif (my ($filename, $line_num, $cond)
+ = $line =~ /\A(\S+[^:]):(\d+)\s*(.*)/ms) {
+ cmd_b_filename_line(
+ $filename,
+ $line_num,
+ (length($cond) ? $cond : '1'),
+ );
+ }
+ # b <sub name> [<condition>]
+ elsif ( my ($new_subname, $new_cond) =
+ $line =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ ) {
+
+ #
+ $subname = $new_subname;
+ cmd_b_sub( $subname, $default_cond->($new_cond) );
+ }
+
+ # b <line> [<condition>].
+ elsif ( my ($line_n, $cond) = $line =~ /^(\d*)\s*(.*)/ ) {
+
+ # Capture the line. If none, it's the current line.
+ $line = $line_n || $dbline;
+
+ # Break on line.
+ cmd_b_line( $line, $default_cond->($cond) );
+ }
+
+ # Line didn't make sense.
+ else {
+ print "confused by line($line)?\r\n";
+ }
+
+ return;
+} ## end sub cmd_b
+
+=head3 C<break_on_load> (API)
+
+We want to break when this file is loaded. Mark this file in the
+C<%break_on_load> hash, and note that it has a breakpoint in
+C<%had_breakpoints>.
+
+=cut
+
+sub break_on_load {
+ my $file = shift;
+ return if $file eq "perl5db.pl";
+
+ $break_on_load{$file} = 1;
+ $had_breakpoints{$file} |= 1;
+}
+
+=head3 C<report_break_on_load> (API)
+
+Gives us an array of filenames that are set to break on load. Note that
+only files with break-on-load are in here, so simply showing the keys
+suffices.
+
+=cut
+
+sub report_break_on_load {
+ sort keys %break_on_load;
+}
+
+=head3 C<cmd_b_load> (command)
+
+We take the file passed in and try to find it in C<%INC> (which maps modules
+to files they came from). We mark those files for break-on-load via
+C<break_on_load> and then report that it was done.
+
+=cut
+
+sub cmd_b_load {
+ my $file = shift;
+ my @files;
+
+ return if $file eq "perl5db.pl";
+
+ # This is a block because that way we can use a redo inside it
+ # even without there being any looping structure at all outside it.
+ {
+
+ # Save short name and full path if found.
+ push @files, $file;
+ push @files, $::INC{$file} if $::INC{$file};
+
+ # Tack on .pm and do it again unless there was a '.' in the name
+ # already.
+ $file .= '.pm', redo unless $file =~ /\./;
+ }
+
+ # Do the real work here.
+ break_on_load($_) for @files;
+
+ # All the files that have break-on-load breakpoints.
+ @files = report_break_on_load;
+
+ # Normalize for the purposes of our printing this.
+ local $\ = '';
+ local $" = ' ';
+
+ print $OUT "Will stop on load of '@files'.\r\n";
+
+} ## end sub cmd_b_load
+
+=head3 C<$filename_error> (API package global)
+
+Several of the functions we need to implement in the API need to work both
+on the current file and on other files. We don't want to duplicate code, so
+C<$filename_error> is used to contain the name of the file that's being
+worked on (if it's not the current one).
+
+We can now build functions in pairs: the basic function works on the current
+file, and uses C<$filename_error> as part of its error message. Since this is
+initialized to C<"">, no filename will appear when we are working on the
+current file.
+
+The second function is a wrapper which does the following:
+
+=over 4
+
+=item *
+
+Localizes C<$filename_error> and sets it to the name of the file to be processed.
+
+=item *
+
+Localizes the C<*dbline> glob and reassigns it to point to the file we want to process.
+
+=item *
+
+Calls the first function.
+
+The first function works on the I<current> file (i.e., the one we changed to),
+and prints C<$filename_error> in the error message (the name of the other file)
+if it needs to. When the functions return, C<*dbline> is restored to point
+to the actual current file (the one we're executing in) and
+C<$filename_error> is restored to C<"">. This restores everything to
+the way it was before the second function was called at all.
+
+See the comments in C<breakable_line> and C<breakable_line_in_file> for more
+details.
+
+=back
+
+=cut
+
+use vars qw($filename_error);
+$filename_error = '';
+
+=head3 breakable_line(from, to) (API)
+
+The subroutine decides whether or not a line in the current file is breakable.
+It walks through C<@dbline> within the range of lines specified, looking for
+the first line that is breakable.
+
+If C<$to> is greater than C<$from>, the search moves forwards, finding the
+first line I<after> C<$to> that's breakable, if there is one.
+
+If C<$from> is greater than C<$to>, the search goes I<backwards>, finding the
+first line I<before> C<$to> that's breakable, if there is one.
+
+=cut
+
+sub breakable_line {
+
+ my ( $from, $to ) = @_;
+
+ # $i is the start point. (Where are the FORTRAN programs of yesteryear?)
+ my $i = $from;
+
+ # If there are at least 2 arguments, we're trying to search a range.
+ if ( @_ >= 2 ) {
+
+ # $delta is positive for a forward search, negative for a backward one.
+ my $delta = $from < $to ? +1 : -1;
+
+ # Keep us from running off the ends of the file.
+ my $limit = $delta > 0 ? $#dbline : 1;
+
+ # Clever test. If you're a mathematician, it's obvious why this
+ # test works. If not:
+ # If $delta is positive (going forward), $limit will be $#dbline.
+ # If $to is less than $limit, ($limit - $to) will be positive, times
+ # $delta of 1 (positive), so the result is > 0 and we should use $to
+ # as the stopping point.
+ #
+ # If $to is greater than $limit, ($limit - $to) is negative,
+ # times $delta of 1 (positive), so the result is < 0 and we should
+ # use $limit ($#dbline) as the stopping point.
+ #
+ # If $delta is negative (going backward), $limit will be 1.
+ # If $to is zero, ($limit - $to) will be 1, times $delta of -1
+ # (negative) so the result is > 0, and we use $to as the stopping
+ # point.
+ #
+ # If $to is less than zero, ($limit - $to) will be positive,
+ # times $delta of -1 (negative), so the result is not > 0, and
+ # we use $limit (1) as the stopping point.
+ #
+ # If $to is 1, ($limit - $to) will zero, times $delta of -1
+ # (negative), still giving zero; the result is not > 0, and
+ # we use $limit (1) as the stopping point.
+ #
+ # if $to is >1, ($limit - $to) will be negative, times $delta of -1
+ # (negative), giving a positive (>0) value, so we'll set $limit to
+ # $to.
+
+ $limit = $to if ( $limit - $to ) * $delta > 0;
+
+ # The real search loop.
+ # $i starts at $from (the point we want to start searching from).
+ # We move through @dbline in the appropriate direction (determined
+ # by $delta: either -1 (back) or +1 (ahead).
+ # We stay in as long as we haven't hit an executable line
+ # ($dbline[$i] == 0 means not executable) and we haven't reached
+ # the limit yet (test similar to the above).
+ $i += $delta while $dbline[$i] == 0 and ( $limit - $i ) * $delta > 0;
+
+ } ## end if (@_ >= 2)
+
+ # If $i points to a line that is executable, return that.
+ return $i unless $dbline[$i] == 0;
+
+ # Format the message and print it: no breakable lines in range.
+ my ( $pl, $upto ) = ( '', '' );
+ ( $pl, $upto ) = ( 's', "..$to" ) if @_ >= 2 and $from != $to;
+
+ # If there's a filename in filename_error, we'll see it.
+ # If not, not.
+ die "\r\nLine$pl $from$upto$filename_error not breakable\r\n";
+} ## end sub breakable_line
+
+=head3 breakable_line_in_filename(file, from, to) (API)
+
+Like C<breakable_line>, but look in another file.
+
+=cut
+
+sub breakable_line_in_filename {
+
+ # Capture the file name.
+ my ($f) = shift;
+
+ # Swap the magic line array over there temporarily.
+ local *dbline = $main::{ '_<' . $f };
+
+ # If there's an error, it's in this other file.
+ local $filename_error = " of '$f'";
+
+ # Find the breakable line.
+ breakable_line(@_);
+
+ # *dbline and $filename_error get restored when this block ends.
+
+} ## end sub breakable_line_in_filename
+
+=head3 break_on_line(lineno, [condition]) (API)
+
+Adds a breakpoint with the specified condition (or 1 if no condition was
+specified) to the specified line. Dies if it can't.
+
+=cut
+
+sub break_on_line {
+ my $i = shift;
+ my $cond = @_ ? shift(@_) : 1;
+
+ my $inii = $i;
+ my $after = '';
+ my $pl = '';
+
+ return if $filename eq "perl5db.pl";
+
+ # Woops, not a breakable line. $filename_error allows us to say
+ # if it was in a different file.
+ die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
+
+ # Mark this file as having breakpoints in it.
+ $had_breakpoints{$filename} |= 1;
+
+ # If there is an action or condition here already ...
+ if ( $dbline{$i} ) {
+
+ # ... swap this condition for the existing one.
+ $dbline{$i} =~ s/^[^\0]*/$cond/;
+ }
+ else {
+
+ # Nothing here - just add the condition.
+ $dbline{$i} = $cond;
+
+ _set_breakpoint_enabled_status($filename, $i, 1);
+ }
+
+ unless ( dbutil::isexludedpath($filename)){
+ print "{\"command\": \"breakpoint\", \"file\": \"$filename\", \"line\": $i}\r\n";
+ }
+
+ return;
+} ## end sub break_on_line
+
+=head3 cmd_b_line(line, [condition]) (command)
+
+Wrapper for C<break_on_line>. Prints the failure message if it
+doesn't work.
+
+=cut
+
+sub cmd_b_line {
+ if (not eval { break_on_line(@_); 1 }) {
+ local $\ = '';
+ # print $OUT $@ and return;
+ print $OUT $@;
+ print {$OUT} "\r\n";
+ }
+
+ return;
+} ## end sub cmd_b_line
+
+=head3 cmd_b_filename_line(line, [condition]) (command)
+
+Wrapper for C<break_on_filename_line>. Prints the failure message if it
+doesn't work.
+
+=cut
+
+sub cmd_b_filename_line {
+ if (not eval { break_on_filename_line(@_); 1 }) {
+ local $\ = '';
+ # print $OUT $@ and return;
+ print $OUT $@;
+ print {$OUT} "\r\n";
+
+ }
+
+ return;
+}
+
+=head3 break_on_filename_line(file, line, [condition]) (API)
+
+Switches to the file specified and then calls C<break_on_line> to set
+the breakpoint.
+
+=cut
+
+sub break_on_filename_line {
+ my $f = shift;
+ my $i = shift;
+ my $cond = @_ ? shift(@_) : 1;
+
+ return if $f eq "perl5db.pl";
+
+ # Switch the magical hash temporarily.
+ local *dbline = $main::{ '_<' . $f };
+
+ # Localize the variables that break_on_line uses to make its message.
+ local $filename_error = " of '$f'";
+ local $filename = $f;
+
+ # Add the breakpoint.
+ break_on_line( $i, $cond );
+
+ return;
+} ## end sub break_on_filename_line
+
+=head3 break_on_filename_line_range(file, from, to, [condition]) (API)
+
+Switch to another file, search the range of lines specified for an
+executable one, and put a breakpoint on the first one you find.
+
+=cut
+
+sub break_on_filename_line_range {
+ my $f = shift;
+ my $from = shift;
+ my $to = shift;
+ my $cond = @_ ? shift(@_) : 1;
+
+ return if $f eq "perl5db.pl";
+
+ # Find a breakable line if there is one.
+ my $i = breakable_line_in_filename( $f, $from, $to );
+
+ # Add the breakpoint.
+ break_on_filename_line( $f, $i, $cond );
+
+ return;
+} ## end sub break_on_filename_line_range
+
+=head3 subroutine_filename_lines(subname, [condition]) (API)
+
+Search for a subroutine within a given file. The condition is ignored.
+Uses C<find_sub> to locate the desired subroutine.
+
+=cut
+
+sub subroutine_filename_lines {
+ my ( $subname ) = @_;
+
+ # Returned value from find_sub() is fullpathname:startline-endline.
+ # The match creates the list (fullpathname, start, end).
+ return (find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/);
+} ## end sub subroutine_filename_lines
+
+=head3 break_subroutine(subname) (API)
+
+Places a break on the first line possible in the specified subroutine. Uses
+C<subroutine_filename_lines> to find the subroutine, and
+C<break_on_filename_line_range> to place the break.
+
+=cut
+
+sub break_subroutine {
+ my $subname = shift;
+
+ # Get filename, start, and end.
+ my ( $file, $s, $e ) = subroutine_filename_lines($subname)
+ or die "Subroutine $subname not found.\n";
+
+ return if $file eq "perl5db.pl";
+
+ # Null condition changes to '1' (always true).
+ my $cond = @_ ? shift(@_) : 1;
+
+ # Put a break the first place possible in the range of lines
+ # that make up this subroutine.
+ break_on_filename_line_range( $file, $s, $e, $cond );
+
+ return;
+} ## end sub break_subroutine
+
+=head3 cmd_b_sub(subname, [condition]) (command)
+
+We take the incoming subroutine name and fully-qualify it as best we can.
+
+=over 4
+
+=item 1. If it's already fully-qualified, leave it alone.
+
+=item 2. Try putting it in the current package.
+
+=item 3. If it's not there, try putting it in CORE::GLOBAL if it exists there.
+
+=item 4. If it starts with '::', put it in 'main::'.
+
+=back
+
+After all this cleanup, we call C<break_subroutine> to try to set the
+breakpoint.
+
+=cut
+
+sub cmd_b_sub {
+ my $subname = shift;
+ my $cond = @_ ? shift : 1;
+
+ # If the subname isn't a code reference, qualify it so that
+ # break_subroutine() will work right.
+ if ( ref($subname) ne 'CODE' ) {
+
+ # Not Perl 4.
+ $subname =~ s/'/::/g;
+ my $s = $subname;
+
+ # Put it in this package unless it's already qualified.
+ if ($subname !~ /::/)
+ {
+ $subname = $package . '::' . $subname;
+ };
+
+ # Requalify it into CORE::GLOBAL if qualifying it into this
+ # package resulted in its not being defined, but only do so
+ # if it really is in CORE::GLOBAL.
+ my $core_name = "CORE::GLOBAL::$s";
+ if ((!defined(&$subname))
+ and ($s !~ /::/)
+ and (defined &{$core_name}))
+ {
+ $subname = $core_name;
+ }
+
+ # Put it in package 'main' if it has a leading ::.
+ if ($subname =~ /\A::/)
+ {
+ $subname = "main" . $subname;
+ }
+ } ## end if ( ref($subname) ne 'CODE' ) {
+
+ # Try to set the breakpoint.
+ if (not eval { break_subroutine( $subname, $cond ); 1 }) {
+ local $\ = '';
+ print {$OUT} $@;
+ print {$OUT} "\r\n";
+ return;
+ }
+
+ return;
+} ## end sub cmd_b_sub
+
+=head3 C<cmd_B> - delete breakpoint(s) (command)
+
+The command mostly parses the command line and tries to turn the argument
+into a line spec. If it can't, it uses the current line. It then calls
+C<delete_breakpoint> to actually do the work.
+
+If C<*> is specified, C<cmd_B> calls C<delete_breakpoint> with no arguments,
+thereby deleting all the breakpoints.
+
+=cut
+
+sub cmd_B {
+ my $cmd = shift;
+
+ # No line spec? Use dbline.
+ # If there is one, use it if it's non-zero, or wipe it out if it is.
+ my $line = ( $_[0] =~ /\A\./ ) ? $dbline : (shift || '');
+ my $dbline = shift;
+
+ # If the line was dot, make the line the current one.
+ $line =~ s/^\./$dbline/;
+
+ # If it's * we're deleting all the breakpoints.
+ if ( $line eq '*' ) {
+ if (not eval { delete_breakpoint(); 1 }) {
+ print {$OUT} $@;
+ }
+ }
+
+ # If there is a line spec, delete the breakpoint on that line.
+ elsif ( $line =~ /\A(\S.*)/ ) {
+ if (not eval { delete_breakpoint( $line || $dbline ); 1 }) {
+ local $\ = '';
+ print {$OUT} $@;
+ }
+ } ## end elsif ($line =~ /^(\S.*)/)
+
+ # No line spec.
+ else {
+ print {$OUT}
+ "Deleting a breakpoint requires a line number, or '*' for all\r\n"
+ ; # hint
+ }
+
+ return;
+} ## end sub cmd_B
+
+=head3 delete_breakpoint([line]) (API)
+
+This actually does the work of deleting either a single breakpoint, or all
+of them.
+
+For a single line, we look for it in C<@dbline>. If it's nonbreakable, we
+just drop out with a message saying so. If it is, we remove the condition
+part of the 'condition\0action' that says there's a breakpoint here. If,
+after we've done that, there's nothing left, we delete the corresponding
+line in C<%dbline> to signal that no action needs to be taken for this line.
+
+For all breakpoints, we iterate through the keys of C<%had_breakpoints>,
+which lists all currently-loaded files which have breakpoints. We then look
+at each line in each of these files, temporarily switching the C<%dbline>
+and C<@dbline> structures to point to the files in question, and do what
+we did in the single line case: delete the condition in C<@dbline>, and
+delete the key in C<%dbline> if nothing's left.
+
+We then wholesale delete C<%postponed>, C<%postponed_file>, and
+C<%break_on_load>, because these structures contain breakpoints for files
+and code that haven't been loaded yet. We can just kill these off because there
+are no magical debugger structures associated with them.
+
+=cut
+
+sub _remove_breakpoint_entry {
+ my ($fn, $i) = @_;
+
+ delete $dbline{$i};
+ _delete_breakpoint_data_ref($fn, $i);
+
+ return;
+}
+
+sub _delete_all_breakpoints {
+ print {$OUT} "Deleting all breakpoints...\n";
+
+ # %had_breakpoints lists every file that had at least one
+ # breakpoint in it.
+ for my $fn ( keys %had_breakpoints ) {
+
+ # Switch to the desired file temporarily.
+ local *dbline = $main::{ '_<' . $fn };
+
+ $max = $#dbline;
+
+ # For all lines in this file ...
+ for my $i (1 .. $max) {
+
+ # If there's a breakpoint or action on this line ...
+ if ( defined $dbline{$i} ) {
+
+ # ... remove the breakpoint.
+ $dbline{$i} =~ s/\A[^\0]+//;
+ if ( $dbline{$i} =~ s/\A\0?\z// ) {
+ # Remove the entry altogether if no action is there.
+ _remove_breakpoint_entry($fn, $i);
+ }
+ } ## end if (defined $dbline{$i...
+ } ## end for $i (1 .. $max)
+
+ # If, after we turn off the "there were breakpoints in this file"
+ # bit, the entry in %had_breakpoints for this file is zero,
+ # we should remove this file from the hash.
+ if ( not $had_breakpoints{$fn} &= (~1) ) {
+ delete $had_breakpoints{$fn};
+ }
+ } ## end for my $fn (keys %had_breakpoints)
+
+ # Kill off all the other breakpoints that are waiting for files that
+ # haven't been loaded yet.
+ undef %postponed;
+ undef %postponed_file;
+ undef %break_on_load;
+
+ print {$OUT} "end.\r\n";
+
+ return;
+}
+
+sub _delete_breakpoint_from_line {
+ my ($i) = @_;
+
+ # Woops. This line wasn't breakable at all.
+ die "Line $i not breakable.\n" if $dbline[$i] == 0;
+
+ # Kill the condition, but leave any action.
+ $dbline{$i} =~ s/\A[^\0]*//;
+
+ # Remove the entry entirely if there's no action left.
+ if ($dbline{$i} eq '') {
+ _remove_breakpoint_entry($filename, $i);
+ }
+
+ return;
+}
+
+sub delete_breakpoint {
+ my $i = shift;
+
+ # If we got a line, delete just that one.
+ if ( defined($i) ) {
+ _delete_breakpoint_from_line($i);
+ }
+ # No line; delete them all.
+ else {
+ _delete_all_breakpoints();
+ }
+
+ return;
+}
+
+=head3 cmd_stop (command)
+
+This is meant to be part of the new command API, but it isn't called or used
+anywhere else in the debugger. XXX It is probably meant for use in development
+of new commands.
+
+=cut
+
+sub cmd_stop { # As on ^C, but not signal-safy.
+ $signal = 1;
+ end_report();
+}
+
+=head3 C<cmd_e> - threads
+
+Display the current thread id:
+
+ e
+
+This could be how (when implemented) to send commands to this thread id (e cmd)
+or that thread id (e tid cmd).
+
+=cut
+
+sub cmd_e {
+ my $cmd = shift;
+ my $line = shift;
+ unless (exists($INC{'threads.pm'})) {
+ print "threads not loaded($ENV{PERL5DB_THREADED})
+ please run the debugger with PERL5DB_THREADED=1 set in the environment\n";
+ } else {
+ my $tid = threads->tid;
+ print "thread id: $tid\r\n";
+ }
+} ## end sub cmd_e
+
+=head3 C<cmd_E> - list of thread ids
+
+Display the list of available thread ids:
+
+ E
+
+This could be used (when implemented) to send commands to all threads (E cmd).
+
+=cut
+
+sub cmd_E {
+ my $cmd = shift;
+ my $line = shift;
+ unless (exists($INC{'threads.pm'})) {
+ print "threads not loaded($ENV{PERL5DB_THREADED})
+ please run the debugger with PERL5DB_THREADED=1 set in the environment\n";
+ } else {
+ my $tid = threads->tid;
+ print "thread ids: ".join(', ',
+ map { ($tid == $_->tid ? '<'.$_->tid.'>' : $_->tid) } threads->list
+ )."\n";
+ print {$OUT} "\r\n";
+ }
+} ## end sub cmd_E
+
+=head3 C<cmd_h> - help command (command)
+
+Does the work of either
+
+=over 4
+
+=item *
+
+Showing all the debugger help
+
+=item *
+
+Showing help for a specific command
+
+=back
+
+=cut
+
+use vars qw($help);
+use vars qw($summary);
+
+sub cmd_h {
+ my $cmd = shift;
+
+ # If we have no operand, assume null.
+ my $line = shift || '';
+
+ # 'h h'. Print the long-format help.
+ if ( $line =~ /\Ah\s*\z/ ) {
+ print_help($help);
+ }
+
+ # 'h <something>'. Search for the command and print only its help.
+ elsif ( my ($asked) = $line =~ /\A(\S.*)\z/ ) {
+
+ # support long commands; otherwise bogus errors
+ # happen when you ask for h on <CR> for example
+ my $qasked = quotemeta($asked); # for searching; we don't
+ # want to use it as a pattern.
+ # XXX: finds CR but not <CR>
+
+ # Search the help string for the command.
+ if (
+ $help =~ /^ # Start of a line
+ <? # Optional '<'
+ (?:[IB]<) # Optional markup
+ $qasked # The requested command
+ /mx
+ )
+ {
+
+ # It's there; pull it out and print it.
+ while (
+ $help =~ /^
+ (<? # Optional '<'
+ (?:[IB]<) # Optional markup
+ $qasked # The command
+ ([\s\S]*?) # Description line(s)
+ \n) # End of last description line
+ (?!\s) # Next line not starting with
+ # whitespace
+ /mgx
+ )
+ {
+ print_help($1);
+ }
+ }
+
+ # Not found; not a debugger command.
+ else {
+ print_help("B<$asked> is not a debugger command.\r\n");
+ }
+ } ## end elsif ($line =~ /^(\S.*)$/)
+
+ # 'h' - print the summary help.
+ else {
+ print_help($summary);
+ }
+} ## end sub cmd_h
+
+=head3 C<cmd_i> - inheritance display
+
+Display the (nested) parentage of the module or object given.
+
+=cut
+
+sub cmd_i {
+ my $cmd = shift;
+ my $line = shift;
+ foreach my $isa ( split( /\s+/, $line ) ) {
+ $evalarg = $isa;
+ # The &-call is here to ascertain the mutability of @_.
+ ($isa) = &DB::eval;
+ no strict 'refs';
+ print join(
+ ', ',
+ map {
+ "$_"
+ . (
+ defined( ${"$_\::VERSION"} )
+ ? ' ' . ${"$_\::VERSION"}
+ : undef )
+ } @{mro::get_linear_isa(ref($isa) || $isa)}
+ );
+ print "\n";
+ }
+ print {$OUT} "\r\n";
+} ## end sub cmd_i
+
+=head3 C<cmd_l> - list lines (command)
+
+Most of the command is taken up with transforming all the different line
+specification syntaxes into 'start-stop'. After that is done, the command
+runs a loop over C<@dbline> for the specified range of lines. It handles
+the printing of each line and any markers (C<==E<gt>> for current line,
+C<b> for break on this line, C<a> for action on this line, C<:> for this
+line breakable).
+
+We save the last line listed in the C<$start> global for further listing
+later.
+
+=cut
+
+sub _min {
+ my $min = shift;
+ foreach my $v (@_) {
+ if ($min > $v) {
+ $min = $v;
+ }
+ }
+ return $min;
+}
+
+sub _max {
+ my $max = shift;
+ foreach my $v (@_) {
+ if ($max < $v) {
+ $max = $v;
+ }
+ }
+ return $max;
+}
+
+sub _minify_to_max {
+ my $ref = shift;
+
+ $$ref = _min($$ref, $max);
+
+ return;
+}
+
+sub _cmd_l_handle_var_name {
+ my $var_name = shift;
+
+ $evalarg = $var_name;
+
+ my ($s) = DB::eval();
+
+ # Ooops. Bad scalar.
+ if ($@) {
+ print {$OUT} "Error: $@\r\n";
+ next CMD;
+ }
+
+ # Good scalar. If it's a reference, find what it points to.
+ $s = CvGV_name($s);
+ print {$OUT} "Interpreted as: $1 $s\r\n";
+ $line = "$1 $s";
+
+ # Call self recursively to really do the command.
+ return _cmd_l_main( $s );
+}
+
+sub _cmd_l_handle_subname {
+
+ my $s = $subname;
+
+ # De-Perl4.
+ $subname =~ s/\'/::/;
+
+ # Put it in this package unless it starts with ::.
+ $subname = $package . "::" . $subname unless $subname =~ /::/;
+
+ # Put it in CORE::GLOBAL if t doesn't start with :: and
+ # it doesn't live in this package and it lives in CORE::GLOBAL.
+ $subname = "CORE::GLOBAL::$s"
+ if not defined &$subname
+ and $s !~ /::/
+ and defined &{"CORE::GLOBAL::$s"};
+
+ # Put leading '::' names into 'main::'.
+ $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::";
+
+ # Get name:start-stop from find_sub, and break this up at
+ # colons.
+ my @pieces = split( /:/, find_sub($subname) || $sub{$subname} );
+
+ # Pull off start-stop.
+ my $subrange = pop @pieces;
+
+ # If the name contained colons, the split broke it up.
+ # Put it back together.
+ $file = join( ':', @pieces );
+
+ # If we're not in that file, switch over to it.
+ if ( $file ne $filename ) {
+ if (! $slave_editor) {
+ print {$OUT} "Switching to file '$file'.\r\n";
+ }
+
+ # Switch debugger's magic structures.
+ *dbline = $main::{ '_<' . $file };
+ $max = $#dbline;
+ $filename = $file;
+ } ## end if ($file ne $filename)
+
+ # Subrange is 'start-stop'. If this is less than a window full,
+ # swap it to 'start+', which will list a window from the start point.
+ if ($subrange) {
+ if ( eval($subrange) < -$window ) {
+ $subrange =~ s/-.*/+/;
+ }
+
+ # Call self recursively to list the range.
+ return _cmd_l_main( $subrange );
+ } ## end if ($subrange)
+
+ # Couldn't find it.
+ else {
+ print {$OUT} "Subroutine $subname not found.\r\n";
+ return;
+ }
+}
+
+sub _cmd_l_empty {
+ # Compute new range to list.
+ $incr = $window - 1;
+
+ # Recurse to do it.
+ return _cmd_l_main( $start . '-' . ( $start + $incr ) );
+}
+
+sub _cmd_l_plus {
+ my ($new_start, $new_incr) = @_;
+
+ # Don't reset start for 'l +nnn'.
+ $start = $new_start if $new_start;
+
+ # Increment for list. Use window size if not specified.
+ # (Allows 'l +' to work.)
+ $incr = $new_incr || ($window - 1);
+
+ # Create a line range we'll understand, and recurse to do it.
+ return _cmd_l_main( $start . '-' . ( $start + $incr ) );
+}
+
+sub _cmd_l_calc_initial_end_and_i {
+ my ($spec, $start_match, $end_match) = @_;
+
+ # Determine end point; use end of file if not specified.
+ my $end = ( !defined $start_match ) ? $max :
+ ( $end_match ? $end_match : $start_match );
+
+ # Go on to the end, and then stop.
+ _minify_to_max(\$end);
+
+ # Determine start line.
+ my $i = $start_match;
+
+ if ($i eq '.') {
+ $i = $spec;
+ }
+
+ $i = _max($i, 1);
+
+ $incr = $end - $i;
+
+ return ($end, $i);
+}
+
+sub _cmd_l_range {
+ my ($spec, $current_line, $start_match, $end_match) = @_;
+
+ my ($end, $i) =
+ _cmd_l_calc_initial_end_and_i($spec, $start_match, $end_match);
+
+ # If we're running under a slave editor, force it to show the lines.
+ if ($slave_editor) {
+ print {$OUT} "\032\032$filename:$i:0\r\n";
+ $i = $end;
+ }
+ # We're doing it ourselves. We want to show the line and special
+ # markers for:
+ # - the current line in execution
+ # - whether a line is breakable or not
+ # - whether a line has a break or not
+ # - whether a line has an action or not
+ else {
+ I_TO_END:
+ for ( ; $i <= $end ; $i++ ) {
+
+ # Check for breakpoints and actions.
+ my ( $stop, $action );
+ if ($dbline{$i}) {
+ ( $stop, $action ) = split( /\0/, $dbline{$i} );
+ }
+
+ # ==> if this is the current line in execution,
+ # : if it's breakable.
+ my $arrow =
+ ( $i == $current_line and $filename eq $filename_ini )
+ ? '==>'
+ : ( $dbline[$i] + 0 ? ':' : ' ' );
+
+ # Add break and action indicators.
+ $arrow .= 'b' if $stop;
+ $arrow .= 'a' if $action;
+
+ # Print the line.
+ print {$OUT} "$i$arrow\t", $dbline[$i];
+
+ # Move on to the next line. Drop out on an interrupt.
+ if ($signal) {
+ $i++;
+ last I_TO_END;
+ }
+ } ## end for (; $i <= $end ; $i++)
+
+ # Line the prompt up; print a newline if the last line listed
+ # didn't have a newline.
+ if ($dbline[ $i - 1 ] !~ /\n\z/) {
+ print {$OUT} "\n";
+ }
+ print {$OUT} "\r\n";
+ } ## end else [ if ($slave_editor)
+
+ # Save the point we last listed to in case another relative 'l'
+ # command is desired. Don't let it run off the end.
+ $start = $i;
+ _minify_to_max(\$start);
+
+ return;
+}
+
+sub _cmd_l_main {
+ my $spec = shift;
+
+ # If this is '-something', delete any spaces after the dash.
+ $spec =~ s/\A-\s*\z/-/;
+
+ # If the line is '$something', assume this is a scalar containing a
+ # line number.
+ # Set up for DB::eval() - evaluate in *user* context.
+ if ( my ($var_name) = $spec =~ /\A(\$.*)/s ) {
+ return _cmd_l_handle_var_name($var_name);
+ }
+ # l name. Try to find a sub by that name.
+ elsif ( ($subname) = $spec =~ /\A([\':A-Za-z_][\':\w]*(?:\[.*\])?)/s ) {
+ return _cmd_l_handle_subname();
+ }
+ # Bare 'l' command.
+ elsif ( $spec !~ /\S/ ) {
+ return _cmd_l_empty();
+ }
+ # l [start]+number_of_lines
+ elsif ( my ($new_start, $new_incr) = $spec =~ /\A(\d*)\+(\d*)\z/ ) {
+ return _cmd_l_plus($new_start, $new_incr);
+ }
+ # l start-stop or l start,stop
+ elsif (my ($s, $e) = $spec =~ /^(?:(-?[\d\$\.]+)(?:[-,]([\d\$\.]+))?)?/ ) {
+ return _cmd_l_range($spec, $line, $s, $e);
+ }
+
+ return;
+} ## end sub cmd_l
+
+sub cmd_l {
+ my (undef, $line) = @_;
+
+ return _cmd_l_main($line);
+}
+
+=head3 C<cmd_L> - list breakpoints, actions, and watch expressions (command)
+
+To list breakpoints, the command has to look determine where all of them are
+first. It starts a C<%had_breakpoints>, which tells us what all files have
+breakpoints and/or actions. For each file, we switch the C<*dbline> glob (the
+magic source and breakpoint data structures) to the file, and then look
+through C<%dbline> for lines with breakpoints and/or actions, listing them
+out. We look through C<%postponed> not-yet-compiled subroutines that have
+breakpoints, and through C<%postponed_file> for not-yet-C<require>'d files
+that have breakpoints.
+
+Watchpoints are simpler: we just list the entries in C<@to_watch>.
+
+=cut
+
+sub _cmd_L_calc_arg {
+ # If no argument, list everything. Pre-5.8.0 version always lists
+ # everything
+ my $arg = shift || 'abw';
+ if ($CommandSet ne '580')
+ {
+ $arg = 'abw';
+ }
+
+ return $arg;
+}
+
+sub _cmd_L_calc_wanted_flags {
+ my $arg = _cmd_L_calc_arg(shift);
+
+ return (map { index($arg, $_) >= 0 ? 1 : 0 } qw(a b w));
+}
+
+
+sub _cmd_L_handle_breakpoints {
+ my ($handle_db_line) = @_;
+
+ BREAKPOINTS_SCAN:
+ # Look in all the files with breakpoints...
+ for my $file ( keys %had_breakpoints ) {
+
+ # Temporary switch to this file.
+ local *dbline = $main::{ '_<' . $file };
+
+ # Set up to look through the whole file.
+ $max = $#dbline;
+ my $was; # Flag: did we print something
+ # in this file?
+
+ # For each line in the file ...
+ for my $i (1 .. $max) {
+
+ # We've got something on this line.
+ if ( defined $dbline{$i} ) {
+
+ # Print the header if we haven't.
+ #if (not $was++) {
+ # print {$OUT} "$file:\n";
+ #}
+
+ # Print the line.
+ #print {$OUT} " $i:\t", $dbline[$i];
+
+ $handle_db_line->($dbline{$i});
+
+ # Quit if the user hit interrupt.
+ if ($signal) {
+ last BREAKPOINTS_SCAN;
+ }
+ } ## end if (defined $dbline{$i...
+ } ## end for my $i (1 .. $max)
+ #print {$OUT} "\r\n";
+ } ## end for my $file (keys %had_breakpoints)
+
+ return;
+}
+
+sub _cmd_L_handle_postponed_breakpoints {
+ my ($handle_db_line) = @_;
+
+ print {$OUT} "Postponed breakpoints in files:\n";
+
+ POSTPONED_SCANS:
+ for my $file ( keys %postponed_file ) {
+ my $db = $postponed_file{$file};
+ print {$OUT} " $file:\n";
+ for my $line ( sort { $a <=> $b } keys %$db ) {
+ print {$OUT} " $line:\n";
+
+ $handle_db_line->($db->{$line});
+
+ if ($signal) {
+ last POSTPONED_SCANS;
+ }
+ }
+
+ if ($signal) {
+ last POSTPONED_SCANS;
+ }
+ }
+ print {$OUT} "\r\n";
+
+ return;
+}
+
+
+sub cmd_L {
+ my $cmd = shift;
+
+ my ($action_wanted, $break_wanted, $watch_wanted) =
+ _cmd_L_calc_wanted_flags(shift);
+
+ my $handle_db_line = sub {
+ my ($l) = @_;
+
+ my ( $stop, $action ) = split( /\0/, $l );
+
+ if ($stop and $break_wanted) {
+ print {$OUT} " break if (", $stop, ")\r\n"
+ }
+
+ if ($action && $action_wanted) {
+ print {$OUT} " action: ", $action, "\r\n"
+ }
+
+ return;
+ };
+
+ # Breaks and actions are found together, so we look in the same place
+ # for both.
+ if ( $break_wanted or $action_wanted ) {
+ _cmd_L_handle_breakpoints($handle_db_line);
+ }
+
+ # Look for breaks in not-yet-compiled subs:
+ if ( %postponed and $break_wanted ) {
+ print {$OUT} "Postponed breakpoints in subroutines:\n";
+ my $subname;
+ SUBS_SCAN:
+ for $subname ( keys %postponed ) {
+ print {$OUT} " $subname\t$postponed{$subname}\n";
+ if ($signal) {
+ last SUBS_SCAN;
+ }
+ }
+ print {$OUT} "\r\n";
+ } ## end if (%postponed and $break_wanted)
+
+ # Find files that have not-yet-loaded breaks:
+ my @have = map { # Combined keys
+ keys %{ $postponed_file{$_} }
+ } keys %postponed_file;
+
+ # If there are any, list them.
+ if ( @have and ( $break_wanted or $action_wanted ) ) {
+ _cmd_L_handle_postponed_breakpoints($handle_db_line);
+ } ## end if (@have and ($break_wanted...
+
+ if ( %break_on_load and $break_wanted ) {
+ print {$OUT} "Breakpoints on load:\n";
+ BREAK_ON_LOAD: for my $filename ( keys %break_on_load ) {
+ print {$OUT} " $filename\n";
+ last BREAK_ON_LOAD if $signal;
+ }
+ print {$OUT} "\r\n";
+ } ## end if (%break_on_load and...
+
+ if ($watch_wanted and ( $trace & 2 )) {
+ print {$OUT} "Watch-expressions:\n" if @to_watch;
+ TO_WATCH: for my $expr (@to_watch) {
+ print {$OUT} " $expr\n";
+ last TO_WATCH if $signal;
+ }
+ print {$OUT} "\r\n";
+ }
+
+ return;
+} ## end sub cmd_L
+
+=head3 C<cmd_M> - list modules (command)
+
+Just call C<list_modules>.
+
+=cut
+
+sub cmd_M {
+ list_modules();
+
+ return;
+}
+
+=head3 C<cmd_o> - options (command)
+
+If this is just C<o> by itself, we list the current settings via
+C<dump_option>. If there's a nonblank value following it, we pass that on to
+C<parse_options> for processing.
+
+=cut
+
+sub cmd_o {
+ my $cmd = shift;
+ my $opt = shift || ''; # opt[=val]
+
+ # Nonblank. Try to parse and process.
+ if ( $opt =~ /^(\S.*)/ ) {
+ parse_options($1);
+ }
+
+ # Blank. List the current option settings.
+ else {
+ for (@options) {
+ dump_option($_);
+ }
+ }
+} ## end sub cmd_o
+
+=head3 C<cmd_O> - nonexistent in 5.8.x (command)
+
+Advises the user that the O command has been renamed.
+
+=cut
+
+sub cmd_O {
+ print $OUT "The old O command is now the o command.\n"; # hint
+ print $OUT "Use 'h' to get current command help synopsis or\n"; #
+ print $OUT "use 'o CommandSet=pre580' to revert to old usage\r\n"; #
+}
+
+=head3 C<cmd_v> - view window (command)
+
+Uses the C<$preview> variable set in the second C<BEGIN> block (q.v.) to
+move back a few lines to list the selected line in context. Uses C<cmd_l>
+to do the actual listing after figuring out the range of line to request.
+
+=cut
+
+use vars qw($preview);
+
+sub cmd_v {
+ my $cmd = shift;
+ my $line = shift;
+
+ # Extract the line to list around. (Astute readers will have noted that
+ # this pattern will match whether or not a numeric line is specified,
+ # which means that we'll always enter this loop (though a non-numeric
+ # argument results in no action at all)).
+ if ( $line =~ /^(\d*)$/ ) {
+
+ # Total number of lines to list (a windowful).
+ $incr = $window - 1;
+
+ # Set the start to the argument given (if there was one).
+ $start = $1 if $1;
+
+ # Back up by the context amount.
+ $start -= $preview;
+
+ # Put together a linespec that cmd_l will like.
+ $line = $start . '-' . ( $start + $incr );
+
+ # List the lines.
+ cmd_l( 'l', $line );
+ } ## end if ($line =~ /^(\d*)$/)
+} ## end sub cmd_v
+
+=head3 C<cmd_w> - add a watch expression (command)
+
+The 5.8 version of this command adds a watch expression if one is specified;
+it does nothing if entered with no operands.
+
+We extract the expression, save it, evaluate it in the user's context, and
+save the value. We'll re-evaluate it each time the debugger passes a line,
+and will stop (see the code at the top of the command loop) if the value
+of any of the expressions changes.
+
+=cut
+
+sub _add_watch_expr {
+ my $expr = shift;
+
+ # ... save it.
+ push @to_watch, $expr;
+
+ # Parameterize DB::eval and call it to get the expression's value
+ # in the user's context. This version can handle expressions which
+ # return a list value.
+ $evalarg = $expr;
+ # The &-call is here to ascertain the mutability of @_.
+ my ($val) = join( ' ', &DB::eval);
+ $val = ( defined $val ) ? "'$val'" : 'undef';
+
+ # Save the current value of the expression.
+ push @old_watch, $val;
+
+ # We are now watching expressions.
+ $trace |= 2;
+
+ return;
+}
+
+sub cmd_w {
+ my $cmd = shift;
+
+ # Null expression if no arguments.
+ my $expr = shift || '';
+
+ # If expression is not null ...
+ if ( $expr =~ /\A\S/ ) {
+ _add_watch_expr($expr);
+ } ## end if ($expr =~ /^(\S.*)/)
+
+ # You have to give one to get one.
+ else {
+ print $OUT "Adding a watch-expression requires an expression\r\n"; # hint
+ }
+
+ return;
+}
+
+=head3 C<cmd_W> - delete watch expressions (command)
+
+This command accepts either a watch expression to be removed from the list
+of watch expressions, or C<*> to delete them all.
+
+If C<*> is specified, we simply empty the watch expression list and the
+watch expression value list. We also turn off the bit that says we've got
+watch expressions.
+
+If an expression (or partial expression) is specified, we pattern-match
+through the expressions and remove the ones that match. We also discard
+the corresponding values. If no watch expressions are left, we turn off
+the I<watching expressions> bit.
+
+=cut
+
+sub cmd_W {
+ my $cmd = shift;
+ my $expr = shift || '';
+
+ # Delete them all.
+ if ( $expr eq '*' ) {
+
+ # Not watching now.
+ $trace &= ~2;
+
+ print $OUT "Deleting all watch expressions …\r\n";
+
+ # And all gone.
+ @to_watch = @old_watch = ();
+ }
+
+ # Delete one of them.
+ elsif ( $expr =~ /^(\S.*)/ ) {
+
+ # Where we are in the list.
+ my $i_cnt = 0;
+
+ # For each expression ...
+ foreach (@to_watch) {
+ my $val = $to_watch[$i_cnt];
+
+ # Does this one match the command argument?
+ if ( $val eq $expr ) { # =~ m/^\Q$i$/) {
+ # Yes. Turn it off, and its value too.
+ splice( @to_watch, $i_cnt, 1 );
+ splice( @old_watch, $i_cnt, 1 );
+ }
+ $i_cnt++;
+ } ## end foreach (@to_watch)
+
+ # We don't bother to turn watching off because
+ # a) we don't want to stop calling watchfunction() it it exists
+ # b) foreach over a null list doesn't do anything anyway
+
+ } ## end elsif ($expr =~ /^(\S.*)/)
+
+ # No command arguments entered.
+ else {
+ print $OUT
+ "Deleting a watch-expression requires an expression, or '*' for all\r\n"
+ ; # hint
+ }
+} ## end sub cmd_W
+
+### END of the API section
+
+=head1 SUPPORT ROUTINES
+
+These are general support routines that are used in a number of places
+throughout the debugger.
+
+=head2 save
+
+save() saves the user's versions of globals that would mess us up in C<@saved>,
+and installs the versions we like better.
+
+=cut
+
+sub save {
+
+ # Save eval failure, command failure, extended OS error, output field
+ # separator, input record separator, output record separator and
+ # the warning setting.
+ @saved = ( $@, $!, $^E, $,, $/, $\, $^W );
+
+ $, = ""; # output field separator is null string
+ $/ = "\n"; # input record separator is newline
+ $\ = ""; # output record separator is null string
+ $^W = 0; # warnings are off
+} ## end sub save
+
+=head2 C<print_lineinfo> - show where we are now
+
+print_lineinfo prints whatever it is that it is handed; it prints it to the
+C<$LINEINFO> filehandle instead of just printing it to STDOUT. This allows
+us to feed line information to a slave editor without messing up the
+debugger output.
+
+=cut
+
+sub print_lineinfo {
+
+ # Make the terminal sensible if we're not the primary debugger.
+ resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
+ local $\ = '';
+ local $, = '';
+ print $LINEINFO @_;
+} ## end sub print_lineinfo
+
+=head2 C<postponed_sub>
+
+Handles setting postponed breakpoints in subroutines once they're compiled.
+For breakpoints, we use C<DB::find_sub> to locate the source file and line
+range for the subroutine, then mark the file as having a breakpoint,
+temporarily switch the C<*dbline> glob over to the source file, and then
+search the given range of lines to find a breakable line. If we find one,
+we set the breakpoint on it, deleting the breakpoint from C<%postponed>.
+
+=cut
+
+# The following takes its argument via $evalarg to preserve current @_
+
+sub postponed_sub {
+
+ # Get the subroutine name.
+ my $subname = shift;
+
+ # If this is a 'break +<n> if <condition>' ...
+ if ( $postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s// ) {
+
+ # If there's no offset, use '+0'.
+ my $offset = $1 || 0;
+
+ # find_sub's value is 'fullpath-filename:start-stop'. It's
+ # possible that the filename might have colons in it too.
+ my ( $file, $i ) = ( find_sub($subname) =~ /^(.*):(\d+)-.*$/ );
+ if ($i) {
+
+ # We got the start line. Add the offset '+<n>' from
+ # $postponed{subname}.
+ $i += $offset;
+
+ # Switch to the file this sub is in, temporarily.
+ local *dbline = $main::{ '_<' . $file };
+
+ # No warnings, please.
+ local $^W = 0; # != 0 is magical below
+
+ # This file's got a breakpoint in it.
+ $had_breakpoints{$file} |= 1;
+
+ # Last line in file.
+ $max = $#dbline;
+
+ # Search forward until we hit a breakable line or get to
+ # the end of the file.
+ ++$i until $dbline[$i] != 0 or $i >= $max;
+
+ # Copy the breakpoint in and delete it from %postponed.
+ $dbline{$i} = delete $postponed{$subname};
+ } ## end if ($i)
+
+ # find_sub didn't find the sub.
+ else {
+ local $\ = '';
+ print $OUT "Subroutine $subname not found.\r\n";
+ }
+ return;
+ } ## end if ($postponed{$subname...
+ elsif ( $postponed{$subname} eq 'compile' ) { $signal = 1 }
+
+ #print $OUT "In postponed_sub for '$subname'.\n";
+} ## end sub postponed_sub
+
+=head2 C<postponed>
+
+Called after each required file is compiled, but before it is executed;
+also called if the name of a just-compiled subroutine is a key of
+C<%postponed>. Propagates saved breakpoints (from C<b compile>, C<b load>,
+etc.) into the just-compiled code.
+
+If this is a C<require>'d file, the incoming parameter is the glob
+C<*{"_<$filename"}>, with C<$filename> the name of the C<require>'d file.
+
+If it's a subroutine, the incoming parameter is the subroutine name.
+
+=cut
+
+sub postponed {
+
+ # If there's a break, process it.
+ if ($ImmediateStop) {
+
+ # Right, we've stopped. Turn it off.
+ $ImmediateStop = 0;
+
+ # Enter the command loop when DB::DB gets called.
+ $signal = 1;
+ }
+
+ # If this is a subroutine, let postponed_sub() deal with it.
+ if (ref(\$_[0]) ne 'GLOB') {
+ return postponed_sub(@_);
+ }
+
+ # Not a subroutine. Deal with the file.
+ local *dbline = shift;
+ my $filename = $dbline;
+ $filename =~ s/^_<//;
+ local $\ = '';
+ $signal = 1, print $OUT "'$filename' loaded...\n"
+ if $break_on_load{$filename};
+
+ # print_lineinfo( ' ' x $stack_depth, "Package $filename.\n" ) if $frame;
+ # print "\r\n{\"command\": \"package\", \"file\": \"$filename\", \"stack_depth\": \"$stack_depth\"}\r\n" if $frame;
+
+
+ # Do we have any breakpoints to put in this file?
+ return unless $postponed_file{$filename};
+
+ # Yes. Mark this file as having breakpoints.
+ $had_breakpoints{$filename} |= 1;
+
+ # "Cannot be done: insufficient magic" - we can't just put the
+ # breakpoints saved in %postponed_file into %dbline by assigning
+ # the whole hash; we have to do it one item at a time for the
+ # breakpoints to be set properly.
+ #%dbline = %{$postponed_file{$filename}};
+
+ # Set the breakpoints, one at a time.
+ my $key;
+
+ for $key ( keys %{ $postponed_file{$filename} } ) {
+
+ # Stash the saved breakpoint into the current file's magic line array.
+ $dbline{$key} = ${ $postponed_file{$filename} }{$key};
+ }
+
+ # This file's been compiled; discard the stored breakpoints.
+ delete $postponed_file{$filename};
+
+} ## end sub postponed
+
+=head2 C<dumpit>
+
+C<dumpit> is the debugger's wrapper around dumpvar.pl.
+
+It gets a filehandle (to which C<dumpvar.pl>'s output will be directed) and
+a reference to a variable (the thing to be dumped) as its input.
+
+The incoming filehandle is selected for output (C<dumpvar.pl> is printing to
+the currently-selected filehandle, thank you very much). The current
+values of the package globals C<$single> and C<$trace> are backed up in
+lexicals, and they are turned off (this keeps the debugger from trying
+to single-step through C<dumpvar.pl> (I think.)). C<$frame> is localized to
+preserve its current value and it is set to zero to prevent entry/exit
+messages from printing, and C<$doret> is localized as well and set to -2 to
+prevent return values from being shown.
+
+C<dumpit()> then checks to see if it needs to load C<dumpvar.pl> and
+tries to load it (note: if you have a C<dumpvar.pl> ahead of the
+installed version in C<@INC>, yours will be used instead. Possible security
+problem?).
+
+It then checks to see if the subroutine C<main::dumpValue> is now defined
+it should have been defined by C<dumpvar.pl>). If it has, C<dumpit()>
+localizes the globals necessary for things to be sane when C<main::dumpValue()>
+is called, and picks up the variable to be dumped from the parameter list.
+
+It checks the package global C<%options> to see if there's a C<dumpDepth>
+specified. If not, -1 is assumed; if so, the supplied value gets passed on to
+C<dumpvar.pl>. This tells C<dumpvar.pl> where to leave off when dumping a
+structure: -1 means dump everything.
+
+C<dumpValue()> is then called if possible; if not, C<dumpit()>just prints a
+warning.
+
+In either case, C<$single>, C<$trace>, C<$frame>, and C<$doret> are restored
+and we then return to the caller.
+
+=cut
+
+sub dumpit {
+
+ # Save the current output filehandle and switch to the one
+ # passed in as the first parameter.
+ my $savout = select(shift);
+
+ # Save current settings of $single and $trace, and then turn them off.
+ my $osingle = $single;
+ my $otrace = $trace;
+ $single = $trace = 0;
+
+ # XXX Okay, what do $frame and $doret do, again?
+ local $frame = 0;
+ local $doret = -2;
+
+ # Load dumpvar.pl unless we've already got the sub we need from it.
+ unless ( defined &main::dumpValue ) {
+ do 'dumpvar.pl' or die $@;
+ }
+
+ # If the load succeeded (or we already had dumpvalue()), go ahead
+ # and dump things.
+ if ( defined &main::dumpValue ) {
+ local $\ = '';
+ local $, = '';
+ local $" = ' ';
+ my $v = shift;
+ my $maxdepth = shift || $option{dumpDepth};
+ $maxdepth = -1 unless defined $maxdepth; # -1 means infinite depth
+ main::dumpValue( $v, $maxdepth );
+ } ## end if (defined &main::dumpValue)
+
+ # Oops, couldn't load dumpvar.pl.
+ else {
+ local $\ = '';
+ print $OUT "dumpvar.pl not available.\n";
+ }
+
+ # Reset $single and $trace to their old values.
+ $single = $osingle;
+ $trace = $otrace;
+
+ # Restore the old filehandle.
+ select($savout);
+} ## end sub dumpit
+
+
+
+=head2 C<print_trace>
+
+C<print_trace>'s job is to print a stack trace. It does this via the
+C<dump_trace> routine, which actually does all the ferreting-out of the
+stack trace data. C<print_trace> takes care of formatting it nicely and
+printing it to the proper filehandle.
+
+Parameters:
+
+=over 4
+
+=item *
+
+The filehandle to print to.
+
+=item *
+
+How many frames to skip before starting trace.
+
+=item *
+
+How many frames to print.
+
+=item *
+
+A flag: if true, print a I<short> trace without filenames, line numbers, or arguments
+
+=back
+
+The original comment below seems to be noting that the traceback may not be
+correct if this routine is called in a tied method.
+
+=cut
+
+
+sub zipline{
+ my $line = shift;
+ $line =~ s/\n//g;
+ $line =~ s/\r//g;
+ $line =~ s/\s+/ /g;
+ $line =~ s/\t+/ /g;
+ $line =~ s/'//g;
+ $line =~ s/"//g;
+ return $line;
+}
+
+
+# Tied method do not create a context, so may get wrong message:
+sub print_trace {
+ local $\ = '';
+ my $fh = shift;
+
+ # If this is going to a slave editor, but we're not the primary
+ # debugger, reset it first.
+ resetterm(1)
+ if $fh eq $LINEINFO # slave editor
+ and $LINEINFO eq $OUT # normal output
+ and $term_pid != $$; # not the primary
+
+ # Collect the actual trace information to be formatted.
+ # This is an array of hashes of subroutine call info.
+ my @sub = dump_trace( $_[0] + 1, $_[1] );
+
+ # Grab the "short report" flag from @_.
+ my $short = $_[2]; # Print short report, next one for sub name
+
+
+ my @stackinfo = ();
+
+ # Run through the traceback info, format it, and print it.
+ my $s;
+ for my $i (0 .. $#sub) {
+
+ # Drop out if the user has lost interest and hit control-C.
+ last if $signal;
+
+ # Get the file name.
+ my $file = $sub[$i]{file};
+ if ($i == 0){
+ return if $file =~ m/perl5db.pl$/;
+ }
+
+ # Set the separator so arrys print nice.
+ local $" = ', ';
+
+ # Grab and stringify the arguments if they are there.
+ my $args =
+ defined $sub[$i]{args}
+ ? "(@{ $sub[$i]{args} })"
+ : '';
+
+ # Shorten them up if $maxtrace says they're too long.
+ $args = ( substr $args, 0, $maxtrace - 3 ) . '...'
+ if length $args > $maxtrace;
+
+ # Put in a filename header if short is off.
+ $file = $file eq '-e' ? $file : "file '$file'" unless $short;
+
+ # Get the actual sub's name, and shorten to $maxtrace's requirement.
+ $s = $sub[$i]{'sub'};
+ $s = ( substr $s, 0, $maxtrace - 3 ) . '...' if length $s > $maxtrace;
+
+ my $zline;
+ # Short report uses trimmed file and sub names.
+ if ($short) {
+ my $sub = @_ >= 4 ? $_[3] : $s;
+ #my $line = "\"$sub$args from $file:$sub[$i]{line}\"";
+ my $line = "$sub($args)";
+ $zline = "\"" . zipline($line) . "\"";
+ } ## end if ($short)
+
+ # Non-short report includes full names.
+ else {
+ #my $line = "$s$args". " called from $file". " line $sub[$i]{line}";
+ my $line = "$s($args)";
+ $zline = "\"" . zipline($line) . "\"";
+ }
+
+ push @stackinfo, $zline unless dbutil::isexludedpath($file); # $line =~ m/^$perlsysdir/;
+ } ## end for my $i (0 .. $#sub)
+
+ if($#stackinfo + 1 > 0){
+ my $data = "\r\n{\"command\": \"stack\", \"data\":[";
+ #print "sysdir = $sysdir\n";
+ $data = $data . join(',\n', @stackinfo);
+ $data = $data . "]}\r\n";
+ print $data;
+ #STDOUT->flush();
+ }
+
+} ## end sub print_trace
+
+=head2 dump_trace(skip[,count])
+
+Actually collect the traceback information available via C<caller()>. It does
+some filtering and cleanup of the data, but mostly it just collects it to
+make C<print_trace()>'s job easier.
+
+C<skip> defines the number of stack frames to be skipped, working backwards
+from the most current. C<count> determines the total number of frames to
+be returned; all of them (well, the first 10^9) are returned if C<count>
+is omitted.
+
+This routine returns a list of hashes, from most-recent to least-recent
+stack frame. Each has the following keys and values:
+
+=over 4
+
+=item * C<context> - C<.> (null), C<$> (scalar), or C<@> (array)
+
+=item * C<sub> - subroutine name, or C<eval> information
+
+=item * C<args> - undef, or a reference to an array of arguments
+
+=item * C<file> - the file in which this item was defined (if any)
+
+=item * C<line> - the line on which it was defined
+
+=back
+
+=cut
+
+sub _dump_trace_calc_saved_single_arg
+{
+ my ($nothard, $arg) = @_;
+
+ my $type;
+ if ( not defined $arg ) { # undefined parameter
+ return "undef";
+ }
+
+ elsif ( $nothard and tied $arg ) { # tied parameter
+ return "tied";
+ }
+ elsif ( $nothard and $type = ref $arg ) { # reference
+ return "ref($type)";
+ }
+ else { # can be stringified
+ local $_ =
+ "$arg"; # Safe to stringify now - should not call f().
+
+ # Backslash any single-quotes or backslashes.
+ s/([\'\\])/\\$1/g;
+
+ # Single-quote it unless it's a number or a colon-separated
+ # name.
+ s/(.*)/'$1'/s
+ unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
+
+ # Turn high-bit characters into meta-whatever.
+ s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
+
+ # Turn control characters into ^-whatever.
+ s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
+
+ return $_;
+ }
+}
+
+sub _dump_trace_calc_save_args {
+ my ($nothard) = @_;
+
+ return [
+ map { _dump_trace_calc_saved_single_arg($nothard, $_) } @args
+ ];
+}
+
+sub dump_trace {
+
+ # How many levels to skip.
+ my $skip = shift;
+
+ # How many levels to show. (1e9 is a cheap way of saying "all of them";
+ # it's unlikely that we'll have more than a billion stack frames. If you
+ # do, you've got an awfully big machine...)
+ my $count = shift || 1e9;
+
+ # We increment skip because caller(1) is the first level *back* from
+ # the current one. Add $skip to the count of frames so we have a
+ # simple stop criterion, counting from $skip to $count+$skip.
+ $skip++;
+ $count += $skip;
+
+ # These variables are used to capture output from caller();
+ my ( $p, $file, $line, $sub, $h, $context );
+
+ my ( $e, $r, @sub, $args );
+
+ # XXX Okay... why'd we do that?
+ my $nothard = not $frame & 8;
+ local $frame = 0;
+
+ # Do not want to trace this.
+ my $otrace = $trace;
+ $trace = 0;
+
+ # Start out at the skip count.
+ # If we haven't reached the number of frames requested, and caller() is
+ # still returning something, stay in the loop. (If we pass the requested
+ # number of stack frames, or we run out - caller() returns nothing - we
+ # quit.
+ # Up the stack frame index to go back one more level each time.
+ for (
+ my $i = $skip ;
+ $i < $count
+ and ( $p, $file, $line, $sub, $h, $context, $e, $r ) = caller($i) ;
+ $i++
+ )
+ {
+
+ # Go through the arguments and save them for later.
+ my $save_args = _dump_trace_calc_save_args($nothard);
+
+ # If context is true, this is array (@)context.
+ # If context is false, this is scalar ($) context.
+ # If neither, context isn't defined. (This is apparently a 'can't
+ # happen' trap.)
+ $context = $context ? '@' : ( defined $context ? "\$" : '.' );
+
+ # if the sub has args ($h true), make an anonymous array of the
+ # dumped args.
+ $args = $h ? $save_args : undef;
+
+ # remove trailing newline-whitespace-semicolon-end of line sequence
+ # from the eval text, if any.
+ $e =~ s/\n\s*\;\s*\Z// if $e;
+
+ # Escape backslashed single-quotes again if necessary.
+ $e =~ s/([\\\'])/\\$1/g if $e;
+
+ # if the require flag is true, the eval text is from a require.
+ if ($r) {
+ $sub = "require '$e'";
+ }
+
+ # if it's false, the eval text is really from an eval.
+ elsif ( defined $r ) {
+ $sub = "eval '$e'";
+ }
+
+ # If the sub is '(eval)', this is a block eval, meaning we don't
+ # know what the eval'ed text actually was.
+ elsif ( $sub eq '(eval)' ) {
+ $sub = "eval {...}";
+ }
+
+ # Stick the collected information into @sub as an anonymous hash.
+ push(
+ @sub,
+ {
+ context => $context,
+ sub => $sub,
+ args => $args,
+ file => $file,
+ line => $line
+ }
+ );
+
+ # Stop processing frames if the user hit control-C.
+ last if $signal;
+ } ## end for ($i = $skip ; $i < ...
+
+ # Restore the trace value again.
+ $trace = $otrace;
+ @sub;
+} ## end sub dump_trace
+
+=head2 C<action()>
+
+C<action()> takes input provided as the argument to an add-action command,
+either pre- or post-, and makes sure it's a complete command. It doesn't do
+any fancy parsing; it just keeps reading input until it gets a string
+without a trailing backslash.
+
+=cut
+
+sub action {
+ my $action = shift;
+
+ while ( $action =~ s/\\$// ) {
+
+ # We have a backslash on the end. Read more.
+ $action .= gets();
+ } ## end while ($action =~ s/\\$//)
+
+ # Return the assembled action.
+ $action;
+} ## end sub action
+
+=head2 unbalanced
+
+This routine mostly just packages up a regular expression to be used
+to check that the thing it's being matched against has properly-matched
+curly braces.
+
+Of note is the definition of the C<$balanced_brace_re> global via C<||=>, which
+speeds things up by only creating the qr//'ed expression once; if it's
+already defined, we don't try to define it again. A speed hack.
+
+=cut
+
+use vars qw($balanced_brace_re);
+
+sub unbalanced {
+
+ # I hate using globals!
+ $balanced_brace_re ||= qr{
+ ^ \{
+ (?:
+ (?> [^{}] + ) # Non-parens without backtracking
+ |
+ (??{ $balanced_brace_re }) # Group with matching parens
+ ) *
+ \} $
+ }x;
+ return $_[0] !~ m/$balanced_brace_re/;
+} ## end sub unbalanced
+
+=head2 C<gets()>
+
+C<gets()> is a primitive (very primitive) routine to read continuations.
+It was devised for reading continuations for actions.
+it just reads more input with C<readline()> and returns it.
+
+=cut
+
+sub gets {
+ return DB::readline("cont: ");
+}
+
+=head2 C<_db_system()> - handle calls to<system()> without messing up the debugger
+
+The C<system()> function assumes that it can just go ahead and use STDIN and
+STDOUT, but under the debugger, we want it to use the debugger's input and
+outout filehandles.
+
+C<_db_system()> socks away the program's STDIN and STDOUT, and then substitutes
+the debugger's IN and OUT filehandles for them. It does the C<system()> call,
+and then puts everything back again.
+
+=cut
+
+sub _db_system {
+
+ # We save, change, then restore STDIN and STDOUT to avoid fork() since
+ # some non-Unix systems can do system() but have problems with fork().
+ open( SAVEIN, "<&STDIN" ) || db_warn("Can't save STDIN");
+ open( SAVEOUT, ">&STDOUT" ) || db_warn("Can't save STDOUT");
+ open( STDIN, "<&IN" ) || db_warn("Can't redirect STDIN");
+ open( STDOUT, ">&OUT" ) || db_warn("Can't redirect STDOUT");
+
+ # XXX: using csh or tcsh destroys sigint retvals!
+ system(@_);
+ open( STDIN, "<&SAVEIN" ) || db_warn("Can't restore STDIN");
+ open( STDOUT, ">&SAVEOUT" ) || db_warn("Can't restore STDOUT");
+ close(SAVEIN);
+ close(SAVEOUT);
+
+ # most of the $? crud was coping with broken cshisms
+ if ( $? >> 8 ) {
+ db_warn( "(Command exited ", ( $? >> 8 ), ")\n" );
+ }
+ elsif ($?) {
+ db_warn(
+ "(Command died of SIG#",
+ ( $? & 127 ),
+ ( ( $? & 128 ) ? " -- core dumped" : "" ),
+ ")", "\n"
+ );
+ } ## end elsif ($?)
+
+ return $?;
+
+} ## end sub system
+
+*system = \&_db_system;
+
+=head1 TTY MANAGEMENT
+
+The subs here do some of the terminal management for multiple debuggers.
+
+=head2 setterm
+
+Top-level function called when we want to set up a new terminal for use
+by the debugger.
+
+If the C<noTTY> debugger option was set, we'll either use the terminal
+supplied (the value of the C<noTTY> option), or we'll use C<Term::Rendezvous>
+to find one. If we're a forked debugger, we call C<resetterm> to try to
+get a whole new terminal if we can.
+
+In either case, we set up the terminal next. If the C<ReadLine> option was
+true, we'll get a C<Term::ReadLine> object for the current terminal and save
+the appropriate attributes. We then
+
+=cut
+
+use vars qw($ornaments);
+use vars qw($rl_attribs);
+
+sub setterm {
+
+ # Load Term::Readline, but quietly; don't debug it and don't trace it.
+ local $frame = 0;
+ local $doret = -2;
+ require Term::ReadLine;
+
+ # If noTTY is set, but we have a TTY name, go ahead and hook up to it.
+ if ($notty) {
+ if ($tty) {
+ my ( $i, $o ) = split $tty, /,/;
+ $o = $i unless defined $o;
+ open( IN, "<$i" ) or die "Cannot open TTY '$i' for read: $!";
+ open( OUT, ">$o" ) or die "Cannot open TTY '$o' for write: $!";
+ $IN = \*IN;
+ $OUT = \*OUT;
+ _autoflush($OUT);
+ } ## end if ($tty)
+
+ # We don't have a TTY - try to find one via Term::Rendezvous.
+ else {
+ require Term::Rendezvous;
+
+ # See if we have anything to pass to Term::Rendezvous.
+ # Use $HOME/.perldbtty$$ if not.
+ my $rv = $ENV{PERLDB_NOTTY} || "$ENV{HOME}/.perldbtty$$";
+
+ # Rendezvous and get the filehandles.
+ my $term_rv = Term::Rendezvous->new( $rv );
+ $IN = $term_rv->IN;
+ $OUT = $term_rv->OUT;
+ } ## end else [ if ($tty)
+ } ## end if ($notty)
+
+ # We're a daughter debugger. Try to fork off another TTY.
+ if ( $term_pid eq '-1' ) { # In a TTY with another debugger
+ resetterm(2);
+ }
+
+ # If we shouldn't use Term::ReadLine, don't.
+ if ( !$rl ) {
+ $term = Term::ReadLine::Stub->new( 'perldb', $IN, $OUT );
+ }
+
+ # We're using Term::ReadLine. Get all the attributes for this terminal.
+ else {
+ $term = Term::ReadLine->new( 'perldb', $IN, $OUT );
+
+ $rl_attribs = $term->Attribs;
+ $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
+ if defined $rl_attribs->{basic_word_break_characters}
+ and index( $rl_attribs->{basic_word_break_characters}, ":" ) == -1;
+ $rl_attribs->{special_prefixes} = '$@&%';
+ $rl_attribs->{completer_word_break_characters} .= '$@&%';
+ $rl_attribs->{completion_function} = \&db_complete;
+ } ## end else [ if (!$rl)
+
+ # Set up the LINEINFO filehandle.
+ $LINEINFO = $OUT unless defined $LINEINFO;
+ $lineinfo = $console unless defined $lineinfo;
+
+ $term->MinLine(2);
+
+ load_hist();
+
+ if ( $term->Features->{setHistory} and "@hist" ne "?" ) {
+ $term->SetHistory(@hist);
+ }
+
+ # XXX Ornaments are turned on unconditionally, which is not
+ # always a good thing.
+ ornaments($ornaments) if defined $ornaments;
+ $term_pid = $$;
+} ## end sub setterm
+
+sub load_hist {
+ $histfile //= option_val("HistFile", undef);
+ return unless defined $histfile;
+ open my $fh, "<", $histfile or return;
+ local $/ = "\n";
+ @hist = ();
+ while (<$fh>) {
+ chomp;
+ push @hist, $_;
+ }
+ close $fh;
+}
+
+sub save_hist {
+ return unless defined $histfile;
+ eval { require File::Path } or return;
+ eval { require File::Basename } or return;
+ File::Path::mkpath(File::Basename::dirname($histfile));
+ open my $fh, ">", $histfile or die "Could not open '$histfile': $!";
+ $histsize //= option_val("HistSize",100);
+ my @copy = grep { $_ ne '?' } @hist;
+ my $start = scalar(@copy) > $histsize ? scalar(@copy)-$histsize : 0;
+ for ($start .. $#copy) {
+ print $fh "$copy[$_]\n";
+ }
+ close $fh or die "Could not write '$histfile': $!";
+}
+
+=head1 GET_FORK_TTY EXAMPLE FUNCTIONS
+
+When the process being debugged forks, or the process invokes a command
+via C<system()> which starts a new debugger, we need to be able to get a new
+C<IN> and C<OUT> filehandle for the new debugger. Otherwise, the two processes
+fight over the terminal, and you can never quite be sure who's going to get the
+input you're typing.
+
+C<get_fork_TTY> is a glob-aliased function which calls the real function that
+is tasked with doing all the necessary operating system mojo to get a new
+TTY (and probably another window) and to direct the new debugger to read and
+write there.
+
+The debugger provides C<get_fork_TTY> functions which work for TCP
+socket servers, X11, OS/2, and Mac OS X. Other systems are not
+supported. You are encouraged to write C<get_fork_TTY> functions which
+work for I<your> platform and contribute them.
+
+=head3 C<socket_get_fork_TTY>
+
+=cut
+
+sub connect_remoteport {
+ require IO::Socket;
+
+ my $socket = IO::Socket::INET->new(
+ Timeout => '10',
+ PeerAddr => $remoteport,
+ Proto => 'tcp',
+ );
+ if ( ! $socket ) {
+ die "Unable to connect to remote host: $remoteport\n";
+ }
+ return $socket;
+}
+
+sub socket_get_fork_TTY {
+ $tty = $LINEINFO = $IN = $OUT = connect_remoteport();
+
+ # Do I need to worry about setting $term?
+
+ reset_IN_OUT( $IN, $OUT );
+ return '';
+}
+
+=head3 C<xterm_get_fork_TTY>
+
+This function provides the C<get_fork_TTY> function for X11. If a
+program running under the debugger forks, a new <xterm> window is opened and
+the subsidiary debugger is directed there.
+
+The C<open()> call is of particular note here. We have the new C<xterm>
+we're spawning route file number 3 to STDOUT, and then execute the C<tty>
+command (which prints the device name of the TTY we'll want to use for input
+and output to STDOUT, then C<sleep> for a very long time, routing this output
+to file number 3. This way we can simply read from the <XT> filehandle (which
+is STDOUT from the I<commands> we ran) to get the TTY we want to use.
+
+Only works if C<xterm> is in your path and C<$ENV{DISPLAY}>, etc. are
+properly set up.
+
+=cut
+
+sub xterm_get_fork_TTY {
+ ( my $name = $0 ) =~ s,^.*[/\\],,s;
+ open XT,
+qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
+ sleep 10000000' |];
+
+ # Get the output from 'tty' and clean it up a little.
+ my $tty = <XT>;
+ chomp $tty;
+
+ $pidprompt = ''; # Shown anyway in titlebar
+
+ # We need $term defined or we can not switch to the newly created xterm
+ if ($tty ne '' && !defined $term) {
+ require Term::ReadLine;
+ if ( !$rl ) {
+ $term = Term::ReadLine::Stub->new( 'perldb', $IN, $OUT );
+ }
+ else {
+ $term = Term::ReadLine->new( 'perldb', $IN, $OUT );
+ }
+ }
+ # There's our new TTY.
+ return $tty;
+} ## end sub xterm_get_fork_TTY
+
+=head3 C<os2_get_fork_TTY>
+
+XXX It behooves an OS/2 expert to write the necessary documentation for this!
+
+=cut
+
+# This example function resets $IN, $OUT itself
+my $c_pipe = 0;
+sub os2_get_fork_TTY { # A simplification of the following (and works without):
+ local $\ = '';
+ ( my $name = $0 ) =~ s,^.*[/\\],,s;
+ my %opt = ( title => "Daughter Perl debugger $pids $name",
+ ($rl ? (read_by_key => 1) : ()) );
+ require OS2::Process;
+ my ($in, $out, $pid) = eval { OS2::Process::io_term(related => 0, %opt) }
+ or return;
+ $pidprompt = ''; # Shown anyway in titlebar
+ reset_IN_OUT($in, $out);
+ $tty = '*reset*';
+ return ''; # Indicate that reset_IN_OUT is called
+} ## end sub os2_get_fork_TTY
+
+=head3 C<macosx_get_fork_TTY>
+
+The Mac OS X version uses AppleScript to tell Terminal.app to create
+a new window.
+
+=cut
+
+# Notes about Terminal.app's AppleScript support,
+# (aka things that might break in future OS versions).
+#
+# The "do script" command doesn't return a reference to the new window
+# it creates, but since it appears frontmost and windows are enumerated
+# front to back, we can use "first window" === "window 1".
+#
+# Since "do script" is implemented by supplying the argument (plus a
+# return character) as terminal input, there's a potential race condition
+# where the debugger could beat the shell to reading the command.
+# To prevent this, we wait for the screen to clear before proceeding.
+#
+# 10.3 and 10.4:
+# There's no direct accessor for the tty device name, so we fiddle
+# with the window title options until it says what we want.
+#
+# 10.5:
+# There _is_ a direct accessor for the tty device name, _and_ there's
+# a new possible component of the window title (the name of the settings
+# set). A separate version is needed.
+
+my @script_versions=
+
+ ([237, <<'__LEOPARD__'],
+tell application "Terminal"
+ do script "clear;exec sleep 100000"
+ tell first tab of first window
+ copy tty to thetty
+ set custom title to "forked perl debugger"
+ set title displays custom title to true
+ repeat while (length of first paragraph of (get contents)) > 0
+ delay 0.1
+ end repeat
+ end tell
+end tell
+thetty
+__LEOPARD__
+
+ [100, <<'__JAGUAR_TIGER__'],
+tell application "Terminal"
+ do script "clear;exec sleep 100000"
+ tell first window
+ set title displays shell path to false
+ set title displays window size to false
+ set title displays file name to false
+ set title displays device name to true
+ set title displays custom title to true
+ set custom title to ""
+ copy "/dev/" & name to thetty
+ set custom title to "forked perl debugger"
+ repeat while (length of first paragraph of (get contents)) > 0
+ delay 0.1
+ end repeat
+ end tell
+end tell
+thetty
+__JAGUAR_TIGER__
+
+);
+
+sub macosx_get_fork_TTY
+{
+ my($version,$script,$pipe,$tty);
+
+ return unless $version=$ENV{TERM_PROGRAM_VERSION};
+ foreach my $entry (@script_versions) {
+ if ($version>=$entry->[0]) {
+ $script=$entry->[1];
+ last;
+ }
+ }
+ return unless defined($script);
+ return unless open($pipe,'-|','/usr/bin/osascript','-e',$script);
+ $tty=readline($pipe);
+ close($pipe);
+ return unless defined($tty) && $tty =~ m(^/dev/);
+ chomp $tty;
+ return $tty;
+}
+
+=head2 C<create_IN_OUT($flags)>
+
+Create a new pair of filehandles, pointing to a new TTY. If impossible,
+try to diagnose why.
+
+Flags are:
+
+=over 4
+
+=item * 1 - Don't know how to create a new TTY.
+
+=item * 2 - Debugger has forked, but we can't get a new TTY.
+
+=item * 4 - standard debugger startup is happening.
+
+=back
+
+=cut
+
+use vars qw($fork_TTY);
+
+sub create_IN_OUT { # Create a window with IN/OUT handles redirected there
+
+ # If we know how to get a new TTY, do it! $in will have
+ # the TTY name if get_fork_TTY works.
+ my $in = get_fork_TTY(@_) if defined &get_fork_TTY;
+
+ # It used to be that
+ $in = $fork_TTY if defined $fork_TTY; # Backward compatibility
+
+ if ( not defined $in ) {
+ my $why = shift;
+
+ # We don't know how.
+ print_help(<<EOP) if $why == 1;
+I<#########> Forked, but do not know how to create a new B<TTY>. I<#########>
+EOP
+
+ # Forked debugger.
+ print_help(<<EOP) if $why == 2;
+I<#########> Daughter session, do not know how to change a B<TTY>. I<#########>
+ This may be an asynchronous session, so the parent debugger may be active.
+EOP
+
+ # Note that both debuggers are fighting over the same input.
+ print_help(<<EOP) if $why != 4;
+ Since two debuggers fight for the same TTY, input is severely entangled.
+
+EOP
+ print_help(<<EOP);
+ I know how to switch the output to a different window in xterms, OS/2
+ consoles, and Mac OS X Terminal.app only. For a manual switch, put the name
+ of the created I<TTY> in B<\$DB::fork_TTY>, or define a function
+ B<DB::get_fork_TTY()> returning this.
+
+ On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
+ by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
+
+EOP
+ } ## end if (not defined $in)
+ elsif ( $in ne '' ) {
+ TTY($in);
+ }
+ else {
+ $console = ''; # Indicate no need to open-from-the-console
+ }
+ undef $fork_TTY;
+} ## end sub create_IN_OUT
+
+=head2 C<resetterm>
+
+Handles rejiggering the prompt when we've forked off a new debugger.
+
+If the new debugger happened because of a C<system()> that invoked a
+program under the debugger, the arrow between the old pid and the new
+in the prompt has I<two> dashes instead of one.
+
+We take the current list of pids and add this one to the end. If there
+isn't any list yet, we make one up out of the initial pid associated with
+the terminal and our new pid, sticking an arrow (either one-dashed or
+two dashed) in between them.
+
+If C<CreateTTY> is off, or C<resetterm> was called with no arguments,
+we don't try to create a new IN and OUT filehandle. Otherwise, we go ahead
+and try to do that.
+
+=cut
+
+sub resetterm { # We forked, so we need a different TTY
+
+ # Needs to be passed to create_IN_OUT() as well.
+ my $in = shift;
+
+ # resetterm(2): got in here because of a system() starting a debugger.
+ # resetterm(1): just forked.
+ my $systemed = $in > 1 ? '-' : '';
+
+ # If there's already a list of pids, add this to the end.
+ if ($pids) {
+ $pids =~ s/\]/$systemed->$$]/;
+ }
+
+ # No pid list. Time to make one.
+ else {
+ $pids = "[$term_pid->$$]";
+ }
+
+ # The prompt we're going to be using for this debugger.
+ $pidprompt = $pids;
+
+ # We now 0wnz this terminal.
+ $term_pid = $$;
+
+ # Just return if we're not supposed to try to create a new TTY.
+ return unless $CreateTTY & $in;
+
+ # Try to create a new IN/OUT pair.
+ create_IN_OUT($in);
+} ## end sub resetterm
+
+=head2 C<readline>
+
+First, we handle stuff in the typeahead buffer. If there is any, we shift off
+the next line, print a message saying we got it, add it to the terminal
+history (if possible), and return it.
+
+If there's nothing in the typeahead buffer, check the command filehandle stack.
+If there are any filehandles there, read from the last one, and return the line
+if we got one. If not, we pop the filehandle off and close it, and try the
+next one up the stack.
+
+If we've emptied the filehandle stack, we check to see if we've got a socket
+open, and we read that and return it if we do. If we don't, we just call the
+core C<readline()> and return its value.
+
+=cut
+
+sub readline {
+
+ # Localize to prevent it from being smashed in the program being debugged.
+ local $.;
+
+ # If there are stacked filehandles to read from ...
+ # (Handle it before the typeahead, because we may call source/etc. from
+ # the typeahead.)
+ while (@cmdfhs) {
+
+ # Read from the last one in the stack.
+ my $line = CORE::readline( $cmdfhs[-1] );
+
+ # If we got a line ...
+ defined $line
+ ? ( print $OUT ">> $line" and return $line ) # Echo and return
+ : close pop @cmdfhs; # Pop and close
+ } ## end while (@cmdfhs)
+
+ # Pull a line out of the typeahead if there's stuff there.
+ if (@typeahead) {
+
+ # How many lines left.
+ my $left = @typeahead;
+
+ # Get the next line.
+ my $got = shift @typeahead;
+
+ # Print a message saying we got input from the typeahead.
+ local $\ = '';
+ print $OUT "auto(-$left)", shift, $got, "\r\n";
+
+ # Add it to the terminal history (if possible).
+ $term->AddHistory($got)
+ if length($got) > 1
+ and defined $term->Features->{addHistory};
+ return $got;
+ } ## end if (@typeahead)
+
+ # We really need to read some input. Turn off entry/exit trace and
+ # return value printing.
+ local $frame = 0;
+ local $doret = -2;
+
+ # Nothing on the filehandle stack. Socket?
+ if ( ref $OUT and UNIVERSAL::isa( $OUT, 'IO::Socket::INET' ) ) {
+
+ # Send anything we have to send.
+ $OUT->write( join( '', @_ ) );
+
+ # Receive anything there is to receive.
+ my $stuff = '';
+ my $buf;
+ my $first_time = 1;
+
+ while ($first_time or (length($buf) && ($stuff .= $buf) !~ /\n/))
+ {
+ $first_time = 0;
+ $IN->recv( $buf = '', 2048 ); # XXX "what's wrong with sysread?"
+ # XXX Don't know. You tell me.
+ }
+
+ # What we got.
+ return $stuff;
+ } ## end if (ref $OUT and UNIVERSAL::isa...
+
+ # No socket. Just read from the terminal.
+ else {
+ return $term->readline(@_);
+ }
+} ## end sub readline
+
+=head1 OPTIONS SUPPORT ROUTINES
+
+These routines handle listing and setting option values.
+
+=head2 C<dump_option> - list the current value of an option setting
+
+This routine uses C<option_val> to look up the value for an option.
+It cleans up escaped single-quotes and then displays the option and
+its value.
+
+=cut
+
+sub dump_option {
+ my ( $opt, $val ) = @_;
+ $val = option_val( $opt, 'N/A' );
+ $val =~ s/([\\\'])/\\$1/g;
+ printf $OUT "%20s = '%s'\r\n", $opt, $val;
+} ## end sub dump_option
+
+sub options2remember {
+ foreach my $k (@RememberOnROptions) {
+ $option{$k} = option_val( $k, 'N/A' );
+ }
+ return %option;
+}
+
+=head2 C<option_val> - find the current value of an option
+
+This can't just be a simple hash lookup because of the indirect way that
+the option values are stored. Some are retrieved by calling a subroutine,
+some are just variables.
+
+You must supply a default value to be used in case the option isn't set.
+
+=cut
+
+sub option_val {
+ my ( $opt, $default ) = @_;
+ my $val;
+
+ # Does this option exist, and is it a variable?
+ # If so, retrieve the value via the value in %optionVars.
+ if ( defined $optionVars{$opt}
+ and defined ${ $optionVars{$opt} } )
+ {
+ $val = ${ $optionVars{$opt} };
+ }
+
+ # Does this option exist, and it's a subroutine?
+ # If so, call the subroutine via the ref in %optionAction
+ # and capture the value.
+ elsif ( defined $optionAction{$opt}
+ and defined &{ $optionAction{$opt} } )
+ {
+ $val = &{ $optionAction{$opt} }();
+ }
+
+ # If there's an action or variable for the supplied option,
+ # but no value was set, use the default.
+ elsif (defined $optionAction{$opt} and not defined $option{$opt}
+ or defined $optionVars{$opt} and not defined ${ $optionVars{$opt} } )
+ {
+ $val = $default;
+ }
+
+ # Otherwise, do the simple hash lookup.
+ else {
+ $val = $option{$opt};
+ }
+
+ # If the value isn't defined, use the default.
+ # Then return whatever the value is.
+ $val = $default unless defined $val;
+ $val;
+} ## end sub option_val
+
+=head2 C<parse_options>
+
+Handles the parsing and execution of option setting/displaying commands.
+
+An option entered by itself is assumed to be I<set me to 1> (the default value)
+if the option is a boolean one. If not, the user is prompted to enter a valid
+value or to query the current value (via C<option? >).
+
+If C<option=value> is entered, we try to extract a quoted string from the
+value (if it is quoted). If it's not, we just use the whole value as-is.
+
+We load any modules required to service this option, and then we set it: if
+it just gets stuck in a variable, we do that; if there's a subroutine to
+handle setting the option, we call that.
+
+Finally, if we're running in interactive mode, we display the effect of the
+user's command back to the terminal, skipping this if we're setting things
+during initialization.
+
+=cut
+
+sub parse_options {
+ my ($s) = @_;
+ local $\ = '';
+
+ my $option;
+
+ # These options need a value. Don't allow them to be clobbered by accident.
+ my %opt_needs_val = map { ( $_ => 1 ) } qw{
+ dumpDepth arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize
+ pager quote ReadLine recallCommand RemotePort ShellBang TTY CommandSet
+ };
+
+ while (length($s)) {
+ my $val_defaulted;
+
+ # Clean off excess leading whitespace.
+ $s =~ s/^\s+// && next;
+
+ # Options are always all word characters, followed by a non-word
+ # separator.
+ if ($s !~ s/^(\w+)(\W?)//) {
+ print {$OUT} "Invalid option '$s'\r\n";
+ last;
+ }
+ my ( $opt, $sep ) = ( $1, $2 );
+
+ # Make sure that such an option exists.
+ my $matches = ( grep { /^\Q$opt/ && ( $option = $_ ) } @options )
+ || ( grep { /^\Q$opt/i && ( $option = $_ ) } @options );
+
+ unless ($matches) {
+ print {$OUT} "Unknown option '$opt'\r\n";
+ next;
+ }
+ if ($matches > 1) {
+ print {$OUT} "Ambiguous option '$opt'\r\n";
+ next;
+ }
+ my $val;
+
+ # '?' as separator means query, but must have whitespace after it.
+ if ( "?" eq $sep ) {
+ if ($s =~ /\A\S/) {
+ print {$OUT} "Option query '$opt?' followed by non-space '$s'\n" ;
+
+ last;
+ }
+
+ #&dump_option($opt);
+ } ## end if ("?" eq $sep)
+
+ # Separator is whitespace (or just a carriage return).
+ # They're going for a default, which we assume is 1.
+ elsif ( $sep !~ /\S/ ) {
+ $val_defaulted = 1;
+ $val = "1"; # this is an evil default; make 'em set it!
+ }
+
+ # Separator is =. Trying to set a value.
+ elsif ( $sep eq "=" ) {
+
+ # If quoted, extract a quoted string.
+ if ($s =~ s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
+ my $quote = $1;
+ ( $val = $2 ) =~ s/\\([$quote\\])/$1/g;
+ }
+
+ # Not quoted. Use the whole thing. Warn about 'option='.
+ else {
+ $s =~ s/^(\S*)//;
+ $val = $1;
+ print OUT qq(Option better cleared using $opt=""\r\n)
+ unless length $val;
+ } ## end else [ if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x)
+
+ } ## end elsif ($sep eq "=")
+
+ # "Quoted" with [], <>, or {}.
+ else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
+ my ($end) =
+ "\\" . substr( ")]>}$sep", index( "([<{", $sep ), 1 ); #}
+ $s =~ s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)//
+ or print( $OUT "Unclosed option value '$opt$sep$_'\r\n" ), last;
+ ( $val = $1 ) =~ s/\\([\\$end])/$1/g;
+ } ## end else [ if ("?" eq $sep)
+
+ # Exclude non-booleans from getting set to 1 by default.
+ if ( $opt_needs_val{$option} && $val_defaulted ) {
+ my $cmd = ( $CommandSet eq '580' ) ? 'o' : 'O';
+ print {$OUT}
+"Option '$opt' is non-boolean. Use '$cmd $option=VAL' to set, '$cmd $option?' to query\r\n";
+ next;
+ } ## end if ($opt_needs_val{$option...
+
+ # Save the option value.
+ $option{$option} = $val if defined $val;
+
+ # Load any module that this option requires.
+ if ( defined($optionRequire{$option}) && defined($val) ) {
+ eval qq{
+ local \$frame = 0;
+ local \$doret = -2;
+ require '$optionRequire{$option}';
+ 1;
+ } || die $@ # XXX: shouldn't happen
+ }
+
+ # Set it.
+ # Stick it in the proper variable if it goes in a variable.
+ if (defined($optionVars{$option}) && defined($val)) {
+ ${ $optionVars{$option} } = $val;
+ }
+
+ # Call the appropriate sub if it gets set via sub.
+ if (defined($optionAction{$option})
+ && defined (&{ $optionAction{$option} })
+ && defined ($val))
+ {
+ &{ $optionAction{$option} }($val);
+ }
+
+ # Not initialization - echo the value we set it to.
+ dump_option($option) if ($OUT ne \*STDERR);
+ } ## end while (length)
+} ## end sub parse_options
+
+=head1 RESTART SUPPORT
+
+These routines are used to store (and restore) lists of items in environment
+variables during a restart.
+
+=head2 set_list
+
+Set_list packages up items to be stored in a set of environment variables
+(VAR_n, containing the number of items, and VAR_0, VAR_1, etc., containing
+the values). Values outside the standard ASCII charset are stored by encoding
+then as hexadecimal values.
+
+=cut
+
+sub set_list {
+ my ( $stem, @list ) = @_;
+ my $val;
+
+ # VAR_n: how many we have. Scalar assignment gets the number of items.
+ $ENV{"${stem}_n"} = @list;
+
+ # Grab each item in the list, escape the backslashes, encode the non-ASCII
+ # as hex, and then save in the appropriate VAR_0, VAR_1, etc.
+ for my $i ( 0 .. $#list ) {
+ $val = $list[$i];
+ $val =~ s/\\/\\\\/g;
+ $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
+ $ENV{"${stem}_$i"} = $val;
+ } ## end for $i (0 .. $#list)
+} ## end sub set_list
+
+=head2 get_list
+
+Reverse the set_list operation: grab VAR_n to see how many we should be getting
+back, and then pull VAR_0, VAR_1. etc. back out.
+
+=cut
+
+sub get_list {
+ my $stem = shift;
+ my @list;
+ my $n = delete $ENV{"${stem}_n"};
+ my $val;
+ for my $i ( 0 .. $n - 1 ) {
+ $val = delete $ENV{"${stem}_$i"};
+ $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
+ push @list, $val;
+ }
+ @list;
+} ## end sub get_list
+
+=head1 MISCELLANEOUS SIGNAL AND I/O MANAGEMENT
+
+=head2 catch()
+
+The C<catch()> subroutine is the essence of fast and low-impact. We simply
+set an already-existing global scalar variable to a constant value. This
+avoids allocating any memory possibly in the middle of something that will
+get all confused if we do, particularly under I<unsafe signals>.
+
+=cut
+
+sub catch {
+ $signal = 1;
+ return; # Put nothing on the stack - malloc/free land!
+}
+
+=head2 C<warn()>
+
+C<warn> emits a warning, by joining together its arguments and printing
+them, with couple of fillips.
+
+If the composited message I<doesn't> end with a newline, we automatically
+add C<$!> and a newline to the end of the message. The subroutine expects $OUT
+to be set to the filehandle to be used to output warnings; it makes no
+assumptions about what filehandles are available.
+
+=cut
+
+sub _db_warn {
+ my ($msg) = join( "", @_ );
+ $msg .= ": $!\n" unless $msg =~ /\n$/;
+ local $\ = '';
+ print $OUT $msg;
+} ## end sub warn
+
+*warn = \&_db_warn;
+
+=head1 INITIALIZATION TTY SUPPORT
+
+=head2 C<reset_IN_OUT>
+
+This routine handles restoring the debugger's input and output filehandles
+after we've tried and failed to move them elsewhere. In addition, it assigns
+the debugger's output filehandle to $LINEINFO if it was already open there.
+
+=cut
+
+sub reset_IN_OUT {
+ my $switch_li = $LINEINFO eq $OUT;
+
+ # If there's a term and it's able to get a new tty, try to get one.
+ if ( $term and $term->Features->{newTTY} ) {
+ ( $IN, $OUT ) = ( shift, shift );
+ $term->newTTY( $IN, $OUT );
+ }
+
+ # This term can't get a new tty now. Better luck later.
+ elsif ($term) {
+ _db_warn("Too late to set IN/OUT filehandles, enabled on next 'R'!\n");
+ }
+
+ # Set the filehndles up as they were.
+ else {
+ ( $IN, $OUT ) = ( shift, shift );
+ }
+
+ # Unbuffer the output filehandle.
+ _autoflush($OUT);
+
+ # Point LINEINFO to the same output filehandle if it was there before.
+ $LINEINFO = $OUT if $switch_li;
+} ## end sub reset_IN_OUT
+
+=head1 OPTION SUPPORT ROUTINES
+
+The following routines are used to process some of the more complicated
+debugger options.
+
+=head2 C<TTY>
+
+Sets the input and output filehandles to the specified files or pipes.
+If the terminal supports switching, we go ahead and do it. If not, and
+there's already a terminal in place, we save the information to take effect
+on restart.
+
+If there's no terminal yet (for instance, during debugger initialization),
+we go ahead and set C<$console> and C<$tty> to the file indicated.
+
+=cut
+
+sub TTY {
+
+ if ( @_ and $term and $term->Features->{newTTY} ) {
+
+ # This terminal supports switching to a new TTY.
+ # Can be a list of two files, or on string containing both names,
+ # comma-separated.
+ # XXX Should this perhaps be an assignment from @_?
+ my ( $in, $out ) = shift;
+ if ( $in =~ /,/ ) {
+
+ # Split list apart if supplied.
+ ( $in, $out ) = split /,/, $in, 2;
+ }
+ else {
+
+ # Use the same file for both input and output.
+ $out = $in;
+ }
+
+ # Open file onto the debugger's filehandles, if you can.
+ open IN, $in or die "cannot open '$in' for read: $!";
+ open OUT, ">$out" or die "cannot open '$out' for write: $!";
+
+ # Swap to the new filehandles.
+ reset_IN_OUT( \*IN, \*OUT );
+
+ # Save the setting for later.
+ return $tty = $in;
+ } ## end if (@_ and $term and $term...
+
+ # Terminal doesn't support new TTY, or doesn't support readline.
+ # Can't do it now, try restarting.
+ if ($term and @_) {
+ _db_warn("Too late to set TTY, enabled on next 'R'!\n");
+ }
+
+ # Useful if done through PERLDB_OPTS:
+ $console = $tty = shift if @_;
+
+ # Return whatever the TTY is.
+ $tty or $console;
+} ## end sub TTY
+
+=head2 C<noTTY>
+
+Sets the C<$notty> global, controlling whether or not the debugger tries to
+get a terminal to read from. If called after a terminal is already in place,
+we save the value to use it if we're restarted.
+
+=cut
+
+sub noTTY {
+ if ($term) {
+ _db_warn("Too late to set noTTY, enabled on next 'R'!\n") if @_;
+ }
+ $notty = shift if @_;
+ $notty;
+} ## end sub noTTY
+
+=head2 C<ReadLine>
+
+Sets the C<$rl> option variable. If 0, we use C<Term::ReadLine::Stub>
+(essentially, no C<readline> processing on this I<terminal>). Otherwise, we
+use C<Term::ReadLine>. Can't be changed after a terminal's in place; we save
+the value in case a restart is done so we can change it then.
+
+=cut
+
+sub ReadLine {
+ if ($term) {
+ _db_warn("Too late to set ReadLine, enabled on next 'R'!\n") if @_;
+ }
+ $rl = shift if @_;
+ $rl;
+} ## end sub ReadLine
+
+=head2 C<RemotePort>
+
+Sets the port that the debugger will try to connect to when starting up.
+If the terminal's already been set up, we can't do it, but we remember the
+setting in case the user does a restart.
+
+=cut
+
+sub RemotePort {
+ if ($term) {
+ _db_warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
+ }
+ $remoteport = shift if @_;
+ $remoteport;
+} ## end sub RemotePort
+
+=head2 C<tkRunning>
+
+Checks with the terminal to see if C<Tk> is running, and returns true or
+false. Returns false if the current terminal doesn't support C<readline>.
+
+=cut
+
+sub tkRunning {
+ if ( ${ $term->Features }{tkRunning} ) {
+ return $term->tkRunning(@_);
+ }
+ else {
+ local $\ = '';
+ print $OUT "tkRunning not supported by current ReadLine package.\r\n";
+ 0;
+ }
+} ## end sub tkRunning
+
+=head2 C<NonStop>
+
+Sets nonstop mode. If a terminal's already been set up, it's too late; the
+debugger remembers the setting in case you restart, though.
+
+=cut
+
+sub NonStop {
+ if ($term) {
+ _db_warn("Too late to set up NonStop mode, enabled on next 'R'!\n")
+ if @_;
+ }
+ $runnonstop = shift if @_;
+ $runnonstop;
+} ## end sub NonStop
+
+sub DollarCaretP {
+ if ($term) {
+ _db_warn("Some flag changes could not take effect until next 'R'!\n")
+ if @_;
+ }
+ $^P = parse_DollarCaretP_flags(shift) if @_;
+ expand_DollarCaretP_flags($^P);
+}
+
+=head2 C<pager>
+
+Set up the C<$pager> variable. Adds a pipe to the front unless there's one
+there already.
+
+=cut
+
+sub pager {
+ if (@_) {
+ $pager = shift;
+ $pager = "|" . $pager unless $pager =~ /^(\+?\>|\|)/;
+ }
+ $pager;
+} ## end sub pager
+
+=head2 C<shellBang>
+
+Sets the shell escape command, and generates a printable copy to be used
+in the help.
+
+=cut
+
+sub shellBang {
+
+ # If we got an argument, meta-quote it, and add '\b' if it
+ # ends in a word character.
+ if (@_) {
+ $sh = quotemeta shift;
+ $sh .= "\\b" if $sh =~ /\w$/;
+ }
+
+ # Generate the printable version for the help:
+ $psh = $sh; # copy it
+ $psh =~ s/\\b$//; # Take off trailing \b if any
+ $psh =~ s/\\(.)/$1/g; # De-escape
+ $psh; # return the printable version
+} ## end sub shellBang
+
+=head2 C<ornaments>
+
+If the terminal has its own ornaments, fetch them. Otherwise accept whatever
+was passed as the argument. (This means you can't override the terminal's
+ornaments.)
+
+=cut
+
+sub ornaments {
+ if ( defined $term ) {
+
+ # We don't want to show warning backtraces, but we do want die() ones.
+ local $warnLevel = 0;
+ local $dieLevel = 1;
+
+ # No ornaments if the terminal doesn't support them.
+ if (not $term->Features->{ornaments}) {
+ return '';
+ }
+
+ return (eval { $term->ornaments(@_) } || '');
+ }
+
+ # Use what was passed in if we can't determine it ourselves.
+ else {
+ $ornaments = shift;
+
+ return $ornaments;
+ }
+
+} ## end sub ornaments
+
+=head2 C<recallCommand>
+
+Sets the recall command, and builds a printable version which will appear in
+the help text.
+
+=cut
+
+sub recallCommand {
+
+ # If there is input, metaquote it. Add '\b' if it ends with a word
+ # character.
+ if (@_) {
+ $rc = quotemeta shift;
+ $rc .= "\\b" if $rc =~ /\w$/;
+ }
+
+ # Build it into a printable version.
+ $prc = $rc; # Copy it
+ $prc =~ s/\\b$//; # Remove trailing \b
+ $prc =~ s/\\(.)/$1/g; # Remove escapes
+ return $prc; # Return the printable version
+} ## end sub recallCommand
+
+=head2 C<LineInfo> - where the line number information goes
+
+Called with no arguments, returns the file or pipe that line info should go to.
+
+Called with an argument (a file or a pipe), it opens that onto the
+C<LINEINFO> filehandle, unbuffers the filehandle, and then returns the
+file or pipe again to the caller.
+
+=cut
+
+sub LineInfo {
+ if (@_) {
+ $lineinfo = shift;
+
+ # If this is a valid "thing to be opened for output", tack a
+ # '>' onto the front.
+ my $stream = ( $lineinfo =~ /^(\+?\>|\|)/ ) ? $lineinfo : ">$lineinfo";
+
+ # If this is a pipe, the stream points to a slave editor.
+ $slave_editor = ( $stream =~ /^\|/ );
+
+ my $new_lineinfo_fh;
+ # Open it up and unbuffer it.
+ open ($new_lineinfo_fh , $stream )
+ or _db_warn("Cannot open '$stream' for write");
+ $LINEINFO = $new_lineinfo_fh;
+ _autoflush($LINEINFO);
+ }
+
+ return $lineinfo;
+} ## end sub LineInfo
+
+=head1 COMMAND SUPPORT ROUTINES
+
+These subroutines provide functionality for various commands.
+
+=head2 C<list_modules>
+
+For the C<M> command: list modules loaded and their versions.
+Essentially just runs through the keys in %INC, picks each package's
+C<$VERSION> variable, gets the file name, and formats the information
+for output.
+
+=cut
+
+sub list_modules { # versions
+ my %version;
+ my $file;
+
+ # keys are the "as-loaded" name, values are the fully-qualified path
+ # to the file itself.
+ for ( keys %INC ) {
+ $file = $_; # get the module name
+ s,\.p[lm]$,,i; # remove '.pl' or '.pm'
+ s,/,::,g; # change '/' to '::'
+ s/^perl5db$/DB/; # Special case: debugger
+ # moves to package DB
+ s/^Term::ReadLine::readline$/readline/; # simplify readline
+
+ # If the package has a $VERSION package global (as all good packages
+ # should!) decode it and save as partial message.
+ my $pkg_version = do { no strict 'refs'; ${ $_ . '::VERSION' } };
+ if ( defined $pkg_version ) {
+ $version{$file} = "$pkg_version from ";
+ }
+
+ # Finish up the message with the file the package came from.
+ $version{$file} .= $INC{$file};
+ } ## end for (keys %INC)
+
+ # Hey, dumpit() formats a hash nicely, so why not use it?
+ dumpit( $OUT, \%version );
+} ## end sub list_modules
+
+=head2 C<sethelp()>
+
+Sets up the monster string used to format and print the help.
+
+=head3 HELP MESSAGE FORMAT
+
+The help message is a peculiar format unto itself; it mixes C<pod> I<ornaments>
+(C<< B<> >> C<< I<> >>) with tabs to come up with a format that's fairly
+easy to parse and portable, but which still allows the help to be a little
+nicer than just plain text.
+
+Essentially, you define the command name (usually marked up with C<< B<> >>
+and C<< I<> >>), followed by a tab, and then the descriptive text, ending in a
+newline. The descriptive text can also be marked up in the same way. If you
+need to continue the descriptive text to another line, start that line with
+just tabs and then enter the marked-up text.
+
+If you are modifying the help text, I<be careful>. The help-string parser is
+not very sophisticated, and if you don't follow these rules it will mangle the
+help beyond hope until you fix the string.
+
+=cut
+
+use vars qw($pre580_help);
+use vars qw($pre580_summary);
+
+sub sethelp {
+
+ # XXX: make sure there are tabs between the command and explanation,
+ # or print_help will screw up your formatting if you have
+ # eeevil ornaments enabled. This is an insane mess.
+
+ $help = "
+Help is currently only available for the new 5.8 command set.
+No help is available for the old command set.
+We assume you know what you're doing if you switch to it.
+
+B<T> Stack trace.
+B<s> [I<expr>] Single step [in I<expr>].
+B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
+<B<CR>> Repeat last B<n> or B<s> command.
+B<r> Return from current subroutine.
+B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
+ at the specified position.
+B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
+B<l> I<min>B<->I<max> List lines I<min> through I<max>.
+B<l> I<line> List single I<line>.
+B<l> I<subname> List first window of lines from subroutine.
+B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
+B<l> List next window of lines.
+B<-> List previous window of lines.
+B<v> [I<line>] View window around I<line>.
+B<.> Return to the executed line.
+B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
+ I<filename> may be either the full name of the file, or a regular
+ expression matching the full file name:
+ B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
+ Evals (with saved bodies) are considered to be filenames:
+ B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
+ (in the order of execution).
+B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
+B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
+B<L> [I<a|b|w>] List actions and or breakpoints and or watch-expressions.
+B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
+B<t> [I<n>] Toggle trace mode (to max I<n> levels below current stack depth).
+B<t> [I<n>] I<expr> Trace through execution of I<expr>.
+B<b> Sets breakpoint on current line)
+B<b> [I<line>] [I<condition>]
+ Set breakpoint; I<line> defaults to the current execution line;
+ I<condition> breaks if it evaluates to true, defaults to '1'.
+B<b> I<subname> [I<condition>]
+ Set breakpoint at first line of subroutine.
+B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
+B<b> B<load> I<filename> Set breakpoint on 'require'ing the given file.
+B<b> B<postpone> I<subname> [I<condition>]
+ Set breakpoint at first line of subroutine after
+ it is compiled.
+B<b> B<compile> I<subname>
+ Stop after the subroutine is compiled.
+B<B> [I<line>] Delete the breakpoint for I<line>.
+B<B> I<*> Delete all breakpoints.
+B<a> [I<line>] I<command>
+ Set an action to be done before the I<line> is executed;
+ I<line> defaults to the current execution line.
+ Sequence is: check for breakpoint/watchpoint, print line
+ if necessary, do action, prompt user if necessary,
+ execute line.
+B<a> Does nothing
+B<A> [I<line>] Delete the action for I<line>.
+B<A> I<*> Delete all actions.
+B<w> I<expr> Add a global watch-expression.
+B<w> Does nothing
+B<W> I<expr> Delete a global watch-expression.
+B<W> I<*> Delete all watch-expressions.
+B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
+ Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
+B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
+B<x> I<expr> Evals expression in list context, dumps the result.
+B<m> I<expr> Evals expression in list context, prints methods callable
+ on the first element of the result.
+B<m> I<class> Prints methods callable via the given class.
+B<M> Show versions of loaded modules.
+B<i> I<class> Prints nested parents of given class.
+B<e> Display current thread id.
+B<E> Display all thread ids the current one will be identified: <n>.
+B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>.
+
+B<<> ? List Perl commands to run before each prompt.
+B<<> I<expr> Define Perl command to run before each prompt.
+B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
+B<< *> Delete the list of perl commands to run before each prompt.
+B<>> ? List Perl commands to run after each prompt.
+B<>> I<expr> Define Perl command to run after each prompt.
+B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
+B<>>B< *> Delete the list of Perl commands to run after each prompt.
+B<{> I<db_command> Define debugger command to run before each prompt.
+B<{> ? List debugger commands to run before each prompt.
+B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
+B<{ *> Delete the list of debugger commands to run before each prompt.
+B<$prc> I<number> Redo a previous command (default previous command).
+B<$prc> I<-number> Redo number'th-to-last command.
+B<$prc> I<pattern> Redo last command that started with I<pattern>.
+ See 'B<O> I<recallCommand>' too.
+B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
+ . (
+ $rc eq $sh
+ ? ""
+ : "
+B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")."
+ ) . "
+ See 'B<O> I<shellBang>' too.
+B<source> I<file> Execute I<file> containing debugger commands (may nest).
+B<save> I<file> Save current debugger session (actual history) to I<file>.
+B<rerun> Rerun session to current position.
+B<rerun> I<n> Rerun session to numbered command.
+B<rerun> I<-n> Rerun session to number'th-to-last command.
+B<H> I<-number> Display last number commands (default all).
+B<H> I<*> Delete complete history.
+B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
+B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
+B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarily select()ed as well.
+B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
+I<command> Execute as a perl statement in current package.
+B<R> Pure-man-restart of debugger, some of debugger state
+ and command-line options may be lost.
+ Currently the following settings are preserved:
+ history, breakpoints and actions, debugger B<O>ptions
+ and the following command-line options: I<-w>, I<-I>, I<-e>.
+
+B<o> [I<opt>] ... Set boolean option to true
+B<o> [I<opt>B<?>] Query options
+B<o> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
+ Set options. Use quotes if spaces in value.
+ I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
+ I<pager> program for output of \"|cmd\";
+ I<tkRunning> run Tk while prompting (with ReadLine);
+ I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
+ I<inhibit_exit> Allows stepping off the end of the script.
+ I<ImmediateStop> Debugger should stop as early as possible.
+ I<RemotePort> Remote hostname:port for remote debugging
+ The following options affect what happens with B<V>, B<X>, and B<x> commands:
+ I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
+ I<compactDump>, I<veryCompact> change style of array and hash dump;
+ I<globPrint> whether to print contents of globs;
+ I<DumpDBFiles> dump arrays holding debugged files;
+ I<DumpPackages> dump symbol tables of packages;
+ I<DumpReused> dump contents of \"reused\" addresses;
+ I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
+ I<bareStringify> Do not print the overload-stringified value;
+ Other options include:
+ I<PrintRet> affects printing of return value after B<r> command,
+ I<frame> affects printing messages on subroutine entry/exit.
+ I<AutoTrace> affects printing messages on possible breaking points.
+ I<maxTraceLen> gives max length of evals/args listed in stack trace.
+ I<ornaments> affects screen appearance of the command line.
+ I<CreateTTY> bits control attempts to create a new TTY on events:
+ 1: on fork() 2: debugger is started inside debugger
+ 4: on startup
+ During startup options are initialized from \$ENV{PERLDB_OPTS}.
+ You can put additional initialization options I<TTY>, I<noTTY>,
+ I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
+ B<R> after you set them).
+
+B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
+B<h> Summary of debugger commands.
+B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
+B<h h> Long help for debugger commands
+B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
+ named Perl I<manpage>, or on B<$doccmd> itself if omitted.
+ Set B<\$DB::doccmd> to change viewer.
+
+Type '|h h' for a paged display if this was too hard to read.
+
+"; # Fix balance of vi % matching: }}}}
+
+ # note: tabs in the following section are not-so-helpful
+ $summary = <<"END_SUM";
+I<List/search source lines:> I<Control script execution:>
+ B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
+ B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
+ B<v> [I<line>] View around line B<n> [I<expr>] Next, steps over subs
+ B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
+ B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
+ B<M> Show module versions B<c> [I<ln>|I<sub>] Continue until position
+I<Debugger controls:> B<L> List break/watch/actions
+ B<o> [...] Set debugger options B<t> [I<n>] [I<expr>] Toggle trace [max depth] ][trace expr]
+ B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
+ B<$prc> [I<N>|I<pat>] Redo a previous command B<B> I<ln|*> Delete a/all breakpoints
+ B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
+ B<=> [I<a> I<val>] Define/list an alias B<A> I<ln|*> Delete a/all actions
+ B<h> [I<db_cmd>] Get help on command B<w> I<expr> Add a watch expression
+ B<h h> Complete help page B<W> I<expr|*> Delete a/all watch exprs
+ B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
+ B<q> or B<^D> Quit B<R> Attempt a restart
+I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
+ B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
+ B<p> I<expr> Print expression (uses script's current package).
+ B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
+ B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
+ B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\". B<i> I<class> inheritance tree.
+ B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>.
+ B<e> Display thread id B<E> Display all thread ids.
+For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
+END_SUM
+
+ # ')}}; # Fix balance of vi % matching
+
+ # and this is really numb...
+ $pre580_help = "
+B<T> Stack trace.
+B<s> [I<expr>] Single step [in I<expr>].
+B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
+B<CR>> Repeat last B<n> or B<s> command.
+B<r> Return from current subroutine.
+B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
+ at the specified position.
+B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
+B<l> I<min>B<->I<max> List lines I<min> through I<max>.
+B<l> I<line> List single I<line>.
+B<l> I<subname> List first window of lines from subroutine.
+B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
+B<l> List next window of lines.
+B<-> List previous window of lines.
+B<w> [I<line>] List window around I<line>.
+B<.> Return to the executed line.
+B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
+ I<filename> may be either the full name of the file, or a regular
+ expression matching the full file name:
+ B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
+ Evals (with saved bodies) are considered to be filenames:
+ B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
+ (in the order of execution).
+B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
+B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
+B<L> List all breakpoints and actions.
+B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
+B<t> [I<n>] Toggle trace mode (to max I<n> levels below current stack depth) .
+B<t> [I<n>] I<expr> Trace through execution of I<expr>.
+B<b> [I<line>] [I<condition>]
+ Set breakpoint; I<line> defaults to the current execution line;
+ I<condition> breaks if it evaluates to true, defaults to '1'.
+B<b> I<subname> [I<condition>]
+ Set breakpoint at first line of subroutine.
+B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
+B<b> B<load> I<filename> Set breakpoint on 'require'ing the given file.
+B<b> B<postpone> I<subname> [I<condition>]
+ Set breakpoint at first line of subroutine after
+ it is compiled.
+B<b> B<compile> I<subname>
+ Stop after the subroutine is compiled.
+B<d> [I<line>] Delete the breakpoint for I<line>.
+B<D> Delete all breakpoints.
+B<a> [I<line>] I<command>
+ Set an action to be done before the I<line> is executed;
+ I<line> defaults to the current execution line.
+ Sequence is: check for breakpoint/watchpoint, print line
+ if necessary, do action, prompt user if necessary,
+ execute line.
+B<a> [I<line>] Delete the action for I<line>.
+B<A> Delete all actions.
+B<W> I<expr> Add a global watch-expression.
+B<W> Delete all watch-expressions.
+B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
+ Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
+B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
+B<x> I<expr> Evals expression in list context, dumps the result.
+B<m> I<expr> Evals expression in list context, prints methods callable
+ on the first element of the result.
+B<m> I<class> Prints methods callable via the given class.
+
+B<<> ? List Perl commands to run before each prompt.
+B<<> I<expr> Define Perl command to run before each prompt.
+B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
+B<>> ? List Perl commands to run after each prompt.
+B<>> I<expr> Define Perl command to run after each prompt.
+B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
+B<{> I<db_command> Define debugger command to run before each prompt.
+B<{> ? List debugger commands to run before each prompt.
+B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
+B<$prc> I<number> Redo a previous command (default previous command).
+B<$prc> I<-number> Redo number'th-to-last command.
+B<$prc> I<pattern> Redo last command that started with I<pattern>.
+ See 'B<O> I<recallCommand>' too.
+B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
+ . (
+ $rc eq $sh
+ ? ""
+ : "
+B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")."
+ ) . "
+ See 'B<O> I<shellBang>' too.
+B<source> I<file> Execute I<file> containing debugger commands (may nest).
+B<H> I<-number> Display last number commands (default all).
+B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
+B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
+B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
+B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
+I<command> Execute as a perl statement in current package.
+B<v> Show versions of loaded modules.
+B<R> Pure-man-restart of debugger, some of debugger state
+ and command-line options may be lost.
+ Currently the following settings are preserved:
+ history, breakpoints and actions, debugger B<O>ptions
+ and the following command-line options: I<-w>, I<-I>, I<-e>.
+
+B<O> [I<opt>] ... Set boolean option to true
+B<O> [I<opt>B<?>] Query options
+B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
+ Set options. Use quotes if spaces in value.
+ I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
+ I<pager> program for output of \"|cmd\";
+ I<tkRunning> run Tk while prompting (with ReadLine);
+ I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
+ I<inhibit_exit> Allows stepping off the end of the script.
+ I<ImmediateStop> Debugger should stop as early as possible.
+ I<RemotePort> Remote hostname:port for remote debugging
+ The following options affect what happens with B<V>, B<X>, and B<x> commands:
+ I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
+ I<compactDump>, I<veryCompact> change style of array and hash dump;
+ I<globPrint> whether to print contents of globs;
+ I<DumpDBFiles> dump arrays holding debugged files;
+ I<DumpPackages> dump symbol tables of packages;
+ I<DumpReused> dump contents of \"reused\" addresses;
+ I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
+ I<bareStringify> Do not print the overload-stringified value;
+ Other options include:
+ I<PrintRet> affects printing of return value after B<r> command,
+ I<frame> affects printing messages on subroutine entry/exit.
+ I<AutoTrace> affects printing messages on possible breaking points.
+ I<maxTraceLen> gives max length of evals/args listed in stack trace.
+ I<ornaments> affects screen appearance of the command line.
+ I<CreateTTY> bits control attempts to create a new TTY on events:
+ 1: on fork() 2: debugger is started inside debugger
+ 4: on startup
+ During startup options are initialized from \$ENV{PERLDB_OPTS}.
+ You can put additional initialization options I<TTY>, I<noTTY>,
+ I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
+ B<R> after you set them).
+
+B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
+B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
+B<h h> Summary of debugger commands.
+B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
+ named Perl I<manpage>, or on B<$doccmd> itself if omitted.
+ Set B<\$DB::doccmd> to change viewer.
+
+Type '|h' for a paged display if this was too hard to read.
+
+"; # Fix balance of vi % matching: }}}}
+
+ # note: tabs in the following section are not-so-helpful
+ $pre580_summary = <<"END_SUM";
+I<List/search source lines:> I<Control script execution:>
+ B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
+ B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
+ B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
+ B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
+ B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
+ B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
+I<Debugger controls:> B<L> List break/watch/actions
+ B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
+ B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
+ B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
+ B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
+ B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
+ B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
+ B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
+ B<q> or B<^D> Quit B<R> Attempt a restart
+I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
+ B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
+ B<p> I<expr> Print expression (uses script's current package).
+ B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
+ B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
+ B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
+ B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>.
+For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
+END_SUM
+
+ # ')}}; # Fix balance of vi % matching
+
+} ## end sub sethelp
+
+=head2 C<print_help()>
+
+Most of what C<print_help> does is just text formatting. It finds the
+C<B> and C<I> ornaments, cleans them off, and substitutes the proper
+terminal control characters to simulate them (courtesy of
+C<Term::ReadLine::TermCap>).
+
+=cut
+
+sub print_help {
+ my $help_str = shift;
+
+ # Restore proper alignment destroyed by eeevil I<> and B<>
+ # ornaments: A pox on both their houses!
+ #
+ # A help command will have everything up to and including
+ # the first tab sequence padded into a field 16 (or if indented 20)
+ # wide. If it's wider than that, an extra space will be added.
+ $help_str =~ s{
+ ^ # only matters at start of line
+ ( \040{4} | \t )* # some subcommands are indented
+ ( < ? # so <CR> works
+ [BI] < [^\t\n] + ) # find an eeevil ornament
+ ( \t+ ) # original separation, discarded
+ ( .* ) # this will now start (no earlier) than
+ # column 16
+ } {
+ my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
+ my $clean = $command;
+ $clean =~ s/[BI]<([^>]*)>/$1/g;
+
+ # replace with this whole string:
+ ($leadwhite ? " " x 4 : "")
+ . $command
+ . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ")
+ . $text;
+
+ }mgex;
+
+ $help_str =~ s{ # handle bold ornaments
+ B < ( [^>] + | > ) >
+ } {
+ $Term::ReadLine::TermCap::rl_term_set[2]
+ . $1
+ . $Term::ReadLine::TermCap::rl_term_set[3]
+ }gex;
+
+ $help_str =~ s{ # handle italic ornaments
+ I < ( [^>] + | > ) >
+ } {
+ $Term::ReadLine::TermCap::rl_term_set[0]
+ . $1
+ . $Term::ReadLine::TermCap::rl_term_set[1]
+ }gex;
+
+ local $\ = '';
+ print {$OUT} $help_str;
+
+ return;
+} ## end sub print_help
+
+=head2 C<fix_less>
+
+This routine does a lot of gyrations to be sure that the pager is C<less>.
+It checks for C<less> masquerading as C<more> and records the result in
+C<$fixed_less> so we don't have to go through doing the stats again.
+
+=cut
+
+use vars qw($fixed_less);
+
+sub _calc_is_less {
+ if ($pager =~ /\bless\b/)
+ {
+ return 1;
+ }
+ elsif ($pager =~ /\bmore\b/)
+ {
+ # Nope, set to more. See what's out there.
+ my @st_more = stat('/usr/bin/more');
+ my @st_less = stat('/usr/bin/less');
+
+ # is it really less, pretending to be more?
+ return (
+ @st_more
+ && @st_less
+ && $st_more[0] == $st_less[0]
+ && $st_more[1] == $st_less[1]
+ );
+ }
+ else {
+ return;
+ }
+}
+
+sub fix_less {
+
+ # We already know if this is set.
+ return if $fixed_less;
+
+ # changes environment!
+ # 'r' added so we don't do (slow) stats again.
+ $fixed_less = 1 if _calc_is_less();
+
+ return;
+} ## end sub fix_less
+
+=head1 DIE AND WARN MANAGEMENT
+
+=head2 C<diesignal>
+
+C<diesignal> is a just-drop-dead C<die> handler. It's most useful when trying
+to debug a debugger problem.
+
+It does its best to report the error that occurred, and then forces the
+program, debugger, and everything to die.
+
+=cut
+
+sub diesignal {
+
+ # No entry/exit messages.
+ local $frame = 0;
+
+ # No return value prints.
+ local $doret = -2;
+
+ # set the abort signal handling to the default (just terminate).
+ $SIG{'ABRT'} = 'DEFAULT';
+
+ # If we enter the signal handler recursively, kill myself with an
+ # abort signal (so we just terminate).
+ kill 'ABRT', $$ if $panic++;
+
+ # If we can show detailed info, do so.
+ if ( defined &Carp::longmess ) {
+
+ # Don't recursively enter the warn handler, since we're carping.
+ local $SIG{__WARN__} = '';
+
+ # Skip two levels before reporting traceback: we're skipping
+ # mydie and confess.
+ local $Carp::CarpLevel = 2; # mydie + confess
+
+ # Tell us all about it.
+ _db_warn( Carp::longmess("Signal @_") );
+ }
+
+ # No Carp. Tell us about the signal as best we can.
+ else {
+ local $\ = '';
+ print $DB::OUT "Got signal @_\r\n";
+ }
+
+ # Drop dead.
+ kill 'ABRT', $$;
+} ## end sub diesignal
+
+=head2 C<dbwarn>
+
+The debugger's own default C<$SIG{__WARN__}> handler. We load C<Carp> to
+be able to get a stack trace, and output the warning message vi C<DB::dbwarn()>.
+
+=cut
+
+sub dbwarn {
+
+ # No entry/exit trace.
+ local $frame = 0;
+
+ # No return value printing.
+ local $doret = -2;
+
+ # Turn off warn and die handling to prevent recursive entries to this
+ # routine.
+ local $SIG{__WARN__} = '';
+ local $SIG{__DIE__} = '';
+
+ # Load Carp if we can. If $^S is false (current thing being compiled isn't
+ # done yet), we may not be able to do a require.
+ eval { require Carp }
+ if defined $^S; # If error/warning during compilation,
+ # require may be broken.
+
+ # Use the core warn() unless Carp loaded OK.
+ CORE::warn( @_,
+ "\nCannot print stack trace, load with -MCarp option to see stack" ),
+ return
+ unless defined &Carp::longmess;
+
+ # Save the current values of $single and $trace, and then turn them off.
+ my ( $mysingle, $mytrace ) = ( $single, $trace );
+ $single = 0;
+ $trace = 0;
+
+ # We can call Carp::longmess without its being "debugged" (which we
+ # don't want - we just want to use it!). Capture this for later.
+ my $mess = Carp::longmess(@_);
+
+ # Restore $single and $trace to their original values.
+ ( $single, $trace ) = ( $mysingle, $mytrace );
+
+ # Use the debugger's own special way of printing warnings to print
+ # the stack trace message.
+ _db_warn($mess);
+} ## end sub dbwarn
+
+=head2 C<dbdie>
+
+The debugger's own C<$SIG{__DIE__}> handler. Handles providing a stack trace
+by loading C<Carp> and calling C<Carp::longmess()> to get it. We turn off
+single stepping and tracing during the call to C<Carp::longmess> to avoid
+debugging it - we just want to use it.
+
+If C<dieLevel> is zero, we let the program being debugged handle the
+exceptions. If it's 1, you get backtraces for any exception. If it's 2,
+the debugger takes over all exception handling, printing a backtrace and
+displaying the exception via its C<dbwarn()> routine.
+
+=cut
+
+sub dbdie {
+ local $frame = 0;
+ local $doret = -2;
+ local $SIG{__DIE__} = '';
+ local $SIG{__WARN__} = '';
+ if ( $dieLevel > 2 ) {
+ local $SIG{__WARN__} = \&dbwarn;
+ _db_warn(@_); # Yell no matter what
+ return;
+ }
+ if ( $dieLevel < 2 ) {
+ die @_ if $^S; # in eval propagate
+ }
+
+ # The code used to check $^S to see if compilation of the current thing
+ # hadn't finished. We don't do it anymore, figuring eval is pretty stable.
+ eval { require Carp };
+
+ die( @_,
+ "\nCannot print stack trace, load with -MCarp option to see stack" )
+ unless defined &Carp::longmess;
+
+ # We do not want to debug this chunk (automatic disabling works
+ # inside DB::DB, but not in Carp). Save $single and $trace, turn them off,
+ # get the stack trace from Carp::longmess (if possible), restore $signal
+ # and $trace, and then die with the stack trace.
+ my ( $mysingle, $mytrace ) = ( $single, $trace );
+ $single = 0;
+ $trace = 0;
+ my $mess = "@_";
+ {
+
+ package Carp; # Do not include us in the list
+ eval { $mess = Carp::longmess(@_); };
+ }
+ ( $single, $trace ) = ( $mysingle, $mytrace );
+ die $mess;
+} ## end sub dbdie
+
+=head2 C<warnlevel()>
+
+Set the C<$DB::warnLevel> variable that stores the value of the
+C<warnLevel> option. Calling C<warnLevel()> with a positive value
+results in the debugger taking over all warning handlers. Setting
+C<warnLevel> to zero leaves any warning handlers set up by the program
+being debugged in place.
+
+=cut
+
+sub warnLevel {
+ if (@_) {
+ my $prevwarn = $SIG{__WARN__} unless $warnLevel;
+ $warnLevel = shift;
+ if ($warnLevel) {
+ $SIG{__WARN__} = \&DB::dbwarn;
+ }
+ elsif ($prevwarn) {
+ $SIG{__WARN__} = $prevwarn;
+ } else {
+ undef $SIG{__WARN__};
+ }
+ } ## end if (@_)
+ $warnLevel;
+} ## end sub warnLevel
+
+=head2 C<dielevel>
+
+Similar to C<warnLevel>. Non-zero values for C<dieLevel> result in the
+C<DB::dbdie()> function overriding any other C<die()> handler. Setting it to
+zero lets you use your own C<die()> handler.
+
+=cut
+
+sub dieLevel {
+ local $\ = '';
+ if (@_) {
+ my $prevdie = $SIG{__DIE__} unless $dieLevel;
+ $dieLevel = shift;
+ if ($dieLevel) {
+
+ # Always set it to dbdie() for non-zero values.
+ $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
+
+ # No longer exists, so don't try to use it.
+ #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
+
+ # If we've finished initialization, mention that stack dumps
+ # are enabled, If dieLevel is 1, we won't stack dump if we die
+ # in an eval().
+ print $OUT "Stack dump during die enabled",
+ ( $dieLevel == 1 ? " outside of evals" : "" ), ".\r\n"
+ if $I_m_init;
+
+ # XXX This is probably obsolete, given that diehard() is gone.
+ print $OUT "Dump printed too.\r\n" if $dieLevel > 2;
+ } ## end if ($dieLevel)
+
+ # Put the old one back if there was one.
+ elsif ($prevdie) {
+ $SIG{__DIE__} = $prevdie;
+ print $OUT "Default die handler restored.\r\n";
+ } else {
+ undef $SIG{__DIE__};
+ print $OUT "Die handler removed.\r\n";
+ }
+ } ## end if (@_)
+ $dieLevel;
+} ## end sub dieLevel
+
+=head2 C<signalLevel>
+
+Number three in a series: set C<signalLevel> to zero to keep your own
+signal handler for C<SIGSEGV> and/or C<SIGBUS>. Otherwise, the debugger
+takes over and handles them with C<DB::diesignal()>.
+
+=cut
+
+sub signalLevel {
+ if (@_) {
+ my $prevsegv = $SIG{SEGV} unless $signalLevel;
+ my $prevbus = $SIG{BUS} unless $signalLevel;
+ $signalLevel = shift;
+ if ($signalLevel) {
+ $SIG{SEGV} = \&DB::diesignal;
+ $SIG{BUS} = \&DB::diesignal;
+ }
+ else {
+ $SIG{SEGV} = $prevsegv;
+ $SIG{BUS} = $prevbus;
+ }
+ } ## end if (@_)
+ $signalLevel;
+} ## end sub signalLevel
+
+=head1 SUBROUTINE DECODING SUPPORT
+
+These subroutines are used during the C<x> and C<X> commands to try to
+produce as much information as possible about a code reference. They use
+L<Devel::Peek> to try to find the glob in which this code reference lives
+(if it does) - this allows us to actually code references which correspond
+to named subroutines (including those aliased via glob assignment).
+
+=head2 C<CvGV_name()>
+
+Wrapper for C<CvGV_name_or_bust>; tries to get the name of a reference
+via that routine. If this fails, return the reference again (when the
+reference is stringified, it'll come out as C<SOMETHING(0x...)>).
+
+=cut
+
+sub CvGV_name {
+ my $in = shift;
+ my $name = CvGV_name_or_bust($in);
+ defined $name ? $name : $in;
+}
+
+=head2 C<CvGV_name_or_bust> I<coderef>
+
+Calls L<Devel::Peek> to try to find the glob the ref lives in; returns
+C<undef> if L<Devel::Peek> can't be loaded, or if C<Devel::Peek::CvGV> can't
+find a glob for this ref.
+
+Returns C<< I<package>::I<glob name> >> if the code ref is found in a glob.
+
+=cut
+
+use vars qw($skipCvGV);
+
+sub CvGV_name_or_bust {
+ my $in = shift;
+ return if $skipCvGV; # Backdoor to avoid problems if XS broken...
+ return unless ref $in;
+ $in = \&$in; # Hard reference...
+ eval { require Devel::Peek; 1 } or return;
+ my $gv = Devel::Peek::CvGV($in) or return;
+ *$gv{PACKAGE} . '::' . *$gv{NAME};
+} ## end sub CvGV_name_or_bust
+
+=head2 C<find_sub>
+
+A utility routine used in various places; finds the file where a subroutine
+was defined, and returns that filename and a line-number range.
+
+Tries to use C<@sub> first; if it can't find it there, it tries building a
+reference to the subroutine and uses C<CvGV_name_or_bust> to locate it,
+loading it into C<@sub> as a side effect (XXX I think). If it can't find it
+this way, it brute-force searches C<%sub>, checking for identical references.
+
+=cut
+
+sub _find_sub_helper {
+ my $subr = shift;
+
+ return unless defined &$subr;
+ my $name = CvGV_name_or_bust($subr);
+ my $data;
+ $data = $sub{$name} if defined $name;
+ return $data if defined $data;
+
+ # Old stupid way...
+ $subr = \&$subr; # Hard reference
+ my $s;
+ for ( keys %sub ) {
+ $s = $_, last if $subr eq \&$_;
+ }
+ if ($s)
+ {
+ return $sub{$s};
+ }
+ else
+ {
+ return;
+ }
+
+}
+
+sub find_sub {
+ my $subr = shift;
+ return ( $sub{$subr} || _find_sub_helper($subr) );
+} ## end sub find_sub
+
+=head2 C<methods>
+
+A subroutine that uses the utility function C<methods_via> to find all the
+methods in the class corresponding to the current reference and in
+C<UNIVERSAL>.
+
+=cut
+
+use vars qw(%seen);
+
+sub methods {
+
+ # Figure out the class - either this is the class or it's a reference
+ # to something blessed into that class.
+ my $class = shift;
+ $class = ref $class if ref $class;
+
+ local %seen;
+
+ # Show the methods that this class has.
+ methods_via( $class, '', 1 );
+
+ # Show the methods that UNIVERSAL has.
+ methods_via( 'UNIVERSAL', 'UNIVERSAL', 0 );
+} ## end sub methods
+
+=head2 C<methods_via($class, $prefix, $crawl_upward)>
+
+C<methods_via> does the work of crawling up the C<@ISA> tree and reporting
+all the parent class methods. C<$class> is the name of the next class to
+try; C<$prefix> is the message prefix, which gets built up as we go up the
+C<@ISA> tree to show parentage; C<$crawl_upward> is 1 if we should try to go
+higher in the C<@ISA> tree, 0 if we should stop.
+
+=cut
+
+sub methods_via {
+
+ # If we've processed this class already, just quit.
+ my $class = shift;
+ return if $seen{$class}++;
+
+ # This is a package that is contributing the methods we're about to print.
+ my $prefix = shift;
+ my $prepend = $prefix ? "via $prefix: " : '';
+ my @to_print;
+
+ # Extract from all the symbols in this class.
+ my $class_ref = do { no strict "refs"; \%{$class . '::'} };
+ while (my ($name, $glob) = each %$class_ref) {
+ # references directly in the symbol table are Proxy Constant
+ # Subroutines, and are by their very nature defined
+ # Otherwise, check if the thing is a typeglob, and if it is, it decays
+ # to a subroutine reference, which can be tested by defined.
+ # $glob might also be the value -1 (from sub foo;)
+ # or (say) '$$' (from sub foo ($$);)
+ # \$glob will be SCALAR in both cases.
+ if ((ref $glob || ($glob && ref \$glob eq 'GLOB' && defined &$glob))
+ && !$seen{$name}++) {
+ push @to_print, "$prepend$name\r\n";
+ }
+ }
+
+ {
+ local $\ = '';
+ local $, = '';
+ print $DB::OUT $_ foreach sort @to_print;
+ }
+
+ # If the $crawl_upward argument is false, just quit here.
+ return unless shift;
+
+ # $crawl_upward true: keep going up the tree.
+ # Find all the classes this one is a subclass of.
+ my $class_ISA_ref = do { no strict "refs"; \@{"${class}::ISA"} };
+ for my $name ( @$class_ISA_ref ) {
+
+ # Set up the new prefix.
+ $prepend = $prefix ? $prefix . " -> $name" : $name;
+
+ # Crawl up the tree and keep trying to crawl up.
+ methods_via( $name, $prepend, 1 );
+ }
+} ## end sub methods_via
+
+=head2 C<setman> - figure out which command to use to show documentation
+
+Just checks the contents of C<$^O> and sets the C<$doccmd> global accordingly.
+
+=cut
+
+sub setman {
+ $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|NetWare)\z/s
+ ? "man" # O Happy Day!
+ : "perldoc"; # Alas, poor unfortunates
+} ## end sub setman
+
+=head2 C<runman> - run the appropriate command to show documentation
+
+Accepts a man page name; runs the appropriate command to display it (set up
+during debugger initialization). Uses C<_db_system()> to avoid mucking up the
+program's STDIN and STDOUT.
+
+=cut
+
+my %_is_in_pods = (map { $_ => 1 }
+ qw(
+ 5004delta
+ 5005delta
+ 561delta
+ 56delta
+ 570delta
+ 571delta
+ 572delta
+ 573delta
+ 58delta
+ 581delta
+ 582delta
+ 583delta
+ 584delta
+ 590delta
+ 591delta
+ 592delta
+ aix
+ amiga
+ apio
+ api
+ artistic
+ book
+ boot
+ bot
+ bs2000
+ call
+ ce
+ cheat
+ clib
+ cn
+ compile
+ cygwin
+ data
+ dbmfilter
+ debguts
+ debtut
+ debug
+ delta
+ dgux
+ diag
+ doc
+ dos
+ dsc
+ ebcdic
+ embed
+ faq1
+ faq2
+ faq3
+ faq4
+ faq5
+ faq6
+ faq7
+ faq8
+ faq9
+ faq
+ filter
+ fork
+ form
+ freebsd
+ func
+ gpl
+ guts
+ hack
+ hist
+ hpux
+ hurd
+ intern
+ intro
+ iol
+ ipc
+ irix
+ jp
+ ko
+ lexwarn
+ locale
+ lol
+ macos
+ macosx
+ modinstall
+ modlib
+ mod
+ modstyle
+ netware
+ newmod
+ number
+ obj
+ opentut
+ op
+ os2
+ os390
+ os400
+ packtut
+ plan9
+ pod
+ podspec
+ port
+ qnx
+ ref
+ reftut
+ re
+ requick
+ reref
+ retut
+ run
+ sec
+ solaris
+ style
+ sub
+ syn
+ thrtut
+ tie
+ toc
+ todo
+ tooc
+ toot
+ trap
+ tru64
+ tw
+ unicode
+ uniintro
+ util
+ uts
+ var
+ vms
+ vos
+ win32
+ xs
+ xstut
+ )
+);
+
+sub runman {
+ my $page = shift;
+ unless ($page) {
+ _db_system("$doccmd $doccmd");
+ return;
+ }
+
+ # this way user can override, like with $doccmd="man -Mwhatever"
+ # or even just "man " to disable the path check.
+ if ( $doccmd ne 'man' ) {
+ _db_system("$doccmd $page");
+ return;
+ }
+
+ $page = 'perl' if lc($page) eq 'help';
+
+ require Config;
+ my $man1dir = $Config::Config{'man1dir'};
+ my $man3dir = $Config::Config{'man3dir'};
+ for ( $man1dir, $man3dir ) { s#/[^/]*\z## if /\S/ }
+ my $manpath = '';
+ $manpath .= "$man1dir:" if $man1dir =~ /\S/;
+ $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
+ chop $manpath if $manpath;
+
+ # harmless if missing, I figure
+ my $oldpath = $ENV{MANPATH};
+ $ENV{MANPATH} = $manpath if $manpath;
+ my $nopathopt = $^O =~ /dunno what goes here/;
+ if (
+ CORE::system(
+ $doccmd,
+
+ # I just *know* there are men without -M
+ ( ( $manpath && !$nopathopt ) ? ( "-M", $manpath ) : () ),
+ split ' ', $page
+ )
+ )
+ {
+ unless ( $page =~ /^perl\w/ ) {
+# do it this way because its easier to slurp in to keep up to date - clunky though.
+ if (exists($_is_in_pods{$page})) {
+ CORE::system( $doccmd,
+ ( ( $manpath && !$nopathopt ) ? ( "-M", $manpath ) : () ),
+ "perl$page" );
+ }
+ }
+ } ## end if (CORE::system($doccmd...
+ if ( defined $oldpath ) {
+ $ENV{MANPATH} = $manpath;
+ }
+ else {
+ delete $ENV{MANPATH};
+ }
+} ## end sub runman
+
+#use Carp; # This did break, left for debugging
+
+=head1 DEBUGGER INITIALIZATION - THE SECOND BEGIN BLOCK
+
+Because of the way the debugger interface to the Perl core is designed, any
+debugger package globals that C<DB::sub()> requires have to be defined before
+any subroutines can be called. These are defined in the second C<BEGIN> block.
+
+This block sets things up so that (basically) the world is sane
+before the debugger starts executing. We set up various variables that the
+debugger has to have set up before the Perl core starts running:
+
+=over 4
+
+=item *
+
+The debugger's own filehandles (copies of STD and STDOUT for now).
+
+=item *
+
+Characters for shell escapes, the recall command, and the history command.
+
+=item *
+
+The maximum recursion depth.
+
+=item *
+
+The size of a C<w> command's window.
+
+=item *
+
+The before-this-line context to be printed in a C<v> (view a window around this line) command.
+
+=item *
+
+The fact that we're not in a sub at all right now.
+
+=item *
+
+The default SIGINT handler for the debugger.
+
+=item *
+
+The appropriate value of the flag in C<$^D> that says the debugger is running
+
+=item *
+
+The current debugger recursion level
+
+=item *
+
+The list of postponed items and the C<$single> stack (XXX define this)
+
+=item *
+
+That we want no return values and no subroutine entry/exit trace.
+
+=back
+
+=cut
+
+# The following BEGIN is very handy if debugger goes havoc, debugging debugger?
+
+use vars qw($db_stop);
+
+BEGIN { # This does not compile, alas. (XXX eh?)
+ $IN = \*STDIN; # For bugs before DB::OUT has been opened
+ $OUT = \*STDERR; # For errors before DB::OUT has been opened
+
+ # Define characters used by command parsing.
+ $sh = '!'; # Shell escape (does not work)
+ $rc = ','; # Recall command (does not work)
+ @hist = ('?'); # Show history (does not work)
+ @truehist = (); # Can be saved for replay (per session)
+
+ # This defines the point at which you get the 'deep recursion'
+ # warning. It MUST be defined or the debugger will not load.
+ $deep = 100;
+
+ # Number of lines around the current one that are shown in the
+ # 'w' command.
+ $window = 10;
+
+ # How much before-the-current-line context the 'v' command should
+ # use in calculating the start of the window it will display.
+ $preview = 3;
+
+ # We're not in any sub yet, but we need this to be a defined value.
+ $sub = '';
+
+ # Set up the debugger's interrupt handler. It simply sets a flag
+ # ($signal) that DB::DB() will check before each command is executed.
+ $SIG{INT} = \&DB::catch;
+
+ # The following lines supposedly, if uncommented, allow the debugger to
+ # debug itself. Perhaps we can try that someday.
+ # This may be enabled to debug debugger:
+ #$warnLevel = 1 unless defined $warnLevel;
+ #$dieLevel = 1 unless defined $dieLevel;
+ #$signalLevel = 1 unless defined $signalLevel;
+
+ # This is the flag that says "a debugger is running, please call
+ # DB::DB and DB::sub". We will turn it on forcibly before we try to
+ # execute anything in the user's context, because we always want to
+ # get control back.
+ $db_stop = 0; # Compiler warning ...
+ $db_stop = 1 << 30; # ... because this is only used in an eval() later.
+
+ # This variable records how many levels we're nested in debugging. Used
+ # Used in the debugger prompt, and in determining whether it's all over or
+ # not.
+ $level = 0; # Level of recursive debugging
+
+ # "Triggers bug (?) in perl if we postpone this until runtime."
+ # XXX No details on this yet, or whether we should fix the bug instead
+ # of work around it. Stay tuned.
+ @stack = (0);
+
+ # Used to track the current stack depth using the auto-stacked-variable
+ # trick.
+ $stack_depth = 0; # Localized repeatedly; simple way to track $#stack
+
+ # Don't print return values on exiting a subroutine.
+ $doret = -2;
+
+ # No extry/exit tracing.
+ $frame = 0;
+
+} ## end BEGIN
+
+BEGIN { $^W = $ini_warn; } # Switch warnings back
+
+=head1 READLINE SUPPORT - COMPLETION FUNCTION
+
+=head2 db_complete
+
+C<readline> support - adds command completion to basic C<readline>.
+
+Returns a list of possible completions to C<readline> when invoked. C<readline>
+will print the longest common substring following the text already entered.
+
+If there is only a single possible completion, C<readline> will use it in full.
+
+This code uses C<map> and C<grep> heavily to create lists of possible
+completion. Think LISP in this section.
+
+=cut
+
+sub db_complete {
+
+ # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
+ # $text is the text to be completed.
+ # $line is the incoming line typed by the user.
+ # $start is the start of the text to be completed in the incoming line.
+ my ( $text, $line, $start ) = @_;
+
+ # Save the initial text.
+ # The search pattern is current package, ::, extract the next qualifier
+ # Prefix and pack are set to undef.
+ my ( $itext, $search, $prefix, $pack ) =
+ ( $text, "^\Q${package}::\E([^:]+)\$" );
+
+=head3 C<b postpone|compile>
+
+=over 4
+
+=item *
+
+Find all the subroutines that might match in this package
+
+=item *
+
+Add C<postpone>, C<load>, and C<compile> as possibles (we may be completing the keyword itself)
+
+=item *
+
+Include all the rest of the subs that are known
+
+=item *
+
+C<grep> out the ones that match the text we have so far
+
+=item *
+
+Return this as the list of possible completions
+
+=back
+
+=cut
+
+ return sort grep /^\Q$text/, ( keys %sub ),
+ qw(postpone load compile), # subroutines
+ ( map { /$search/ ? ($1) : () } keys %sub )
+ if ( substr $line, 0, $start ) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
+
+=head3 C<b load>
+
+Get all the possible files from C<@INC> as it currently stands and
+select the ones that match the text so far.
+
+=cut
+
+ return sort grep /^\Q$text/, values %INC # files
+ if ( substr $line, 0, $start ) =~ /^\|*b\s+load\s+$/;
+
+=head3 C<V> (list variable) and C<m> (list modules)
+
+There are two entry points for these commands:
+
+=head4 Unqualified package names
+
+Get the top-level packages and grab everything that matches the text
+so far. For each match, recursively complete the partial packages to
+get all possible matching packages. Return this sorted list.
+
+=cut
+
+ return sort map { ( $_, db_complete( $_ . "::", "V ", 2 ) ) }
+ grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : () } keys %:: # top-packages
+ if ( substr $line, 0, $start ) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
+
+=head4 Qualified package names
+
+Take a partially-qualified package and find all subpackages for it
+by getting all the subpackages for the package so far, matching all
+the subpackages against the text, and discarding all of them which
+start with 'main::'. Return this list.
+
+=cut
+
+ return sort map { ( $_, db_complete( $_ . "::", "V ", 2 ) ) }
+ grep !/^main::/, grep /^\Q$text/,
+ map { /^(.*)::$/ ? ( $prefix . "::$1" ) : () }
+ do { no strict 'refs'; keys %{ $prefix . '::' } }
+ if ( substr $line, 0, $start ) =~ /^\|*[Vm]\s+$/
+ and $text =~ /^(.*[^:])::?(\w*)$/
+ and $prefix = $1;
+
+=head3 C<f> - switch files
+
+Here, we want to get a fully-qualified filename for the C<f> command.
+Possibilities are:
+
+=over 4
+
+=item 1. The original source file itself
+
+=item 2. A file from C<@INC>
+
+=item 3. An C<eval> (the debugger gets a C<(eval N)> fake file for each C<eval>).
+
+=back
+
+=cut
+
+ if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
+ # We might possibly want to switch to an eval (which has a "filename"
+ # like '(eval 9)'), so we may need to clean up the completion text
+ # before proceeding.
+ $prefix = length($1) - length($text);
+ $text = $1;
+
+=pod
+
+Under the debugger, source files are represented as C<_E<lt>/fullpath/to/file>
+(C<eval>s are C<_E<lt>(eval NNN)>) keys in C<%main::>. We pull all of these
+out of C<%main::>, add the initial source file, and extract the ones that
+match the completion text so far.
+
+=cut
+
+ return sort
+ map { substr $_, 2 + $prefix } grep /^_<\Q$text/, ( keys %main:: ),
+ $0;
+ } ## end if ($line =~ /^\|*f\s+(.*)/)
+
+=head3 Subroutine name completion
+
+We look through all of the defined subs (the keys of C<%sub>) and
+return both all the possible matches to the subroutine name plus
+all the matches qualified to the current package.
+
+=cut
+
+ if ( ( substr $text, 0, 1 ) eq '&' ) { # subroutines
+ $text = substr $text, 1;
+ $prefix = "&";
+ return sort map "$prefix$_", grep /^\Q$text/, ( keys %sub ),
+ (
+ map { /$search/ ? ($1) : () }
+ keys %sub
+ );
+ } ## end if ((substr $text, 0, ...
+
+=head3 Scalar, array, and hash completion: partially qualified package
+
+Much like the above, except we have to do a little more cleanup:
+
+=cut
+
+ if ( $text =~ /^[\$@%](.*)::(.*)/ ) { # symbols in a package
+
+=pod
+
+=over 4
+
+=item *
+
+Determine the package that the symbol is in. Put it in C<::> (effectively C<main::>) if no package is specified.
+
+=cut
+
+ $pack = ( $1 eq 'main' ? '' : $1 ) . '::';
+
+=pod
+
+=item *
+
+Figure out the prefix vs. what needs completing.
+
+=cut
+
+ $prefix = ( substr $text, 0, 1 ) . $1 . '::';
+ $text = $2;
+
+=pod
+
+=item *
+
+Look through all the symbols in the package. C<grep> out all the possible hashes/arrays/scalars, and then C<grep> the possible matches out of those. C<map> the prefix onto all the possibilities.
+
+=cut
+
+ my @out = do {
+ no strict 'refs';
+ map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/,
+ keys %$pack;
+ };
+
+=pod
+
+=item *
+
+If there's only one hit, and it's a package qualifier, and it's not equal to the initial text, re-complete it using the symbol we actually found.
+
+=cut
+
+ if ( @out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext ) {
+ return db_complete( $out[0], $line, $start );
+ }
+
+ # Return the list of possibles.
+ return sort @out;
+
+ } ## end if ($text =~ /^[\$@%](.*)::(.*)/)
+
+=pod
+
+=back
+
+=head3 Symbol completion: current package or package C<main>.
+
+=cut
+
+ if ( $text =~ /^[\$@%]/ ) { # symbols (in $package + packages in main)
+=pod
+
+=over 4
+
+=item *
+
+If it's C<main>, delete main to just get C<::> leading.
+
+=cut
+
+ $pack = ( $package eq 'main' ? '' : $package ) . '::';
+
+=pod
+
+=item *
+
+We set the prefix to the item's sigil, and trim off the sigil to get the text to be completed.
+
+=cut
+
+ $prefix = substr $text, 0, 1;
+ $text = substr $text, 1;
+
+ my @out;
+
+=pod
+
+=item *
+
+We look for the lexical scope above DB::DB and auto-complete lexical variables
+if PadWalker could be loaded.
+
+=cut
+
+ if (not $text =~ /::/ and eval { require PadWalker } ) {
+ my $level = 1;
+ while (1) {
+ my @info = caller($level);
+ $level++;
+ $level = -1, last
+ if not @info;
+ last if $info[3] eq 'DB::DB';
+ }
+ if ($level > 0) {
+ my $lexicals = PadWalker::peek_my($level);
+ push @out, grep /^\Q$prefix$text/, keys %$lexicals;
+ }
+ }
+
+=pod
+
+=item *
+
+If the package is C<::> (C<main>), create an empty list; if it's something else, create a list of all the packages known. Append whichever list to a list of all the possible symbols in the current package. C<grep> out the matches to the text entered so far, then C<map> the prefix back onto the symbols.
+
+=cut
+
+ push @out, map "$prefix$_", grep /^\Q$text/,
+ ( grep /^_?[a-zA-Z]/, do { no strict 'refs'; keys %$pack } ),
+ ( $pack eq '::' ? () : ( grep /::$/, keys %:: ) );
+
+=item *
+
+If there's only one hit, it's a package qualifier, and it's not equal to the initial text, recomplete using this symbol.
+
+=back
+
+=cut
+
+ if ( @out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext ) {
+ return db_complete( $out[0], $line, $start );
+ }
+
+ # Return the list of possibles.
+ return sort @out;
+ } ## end if ($text =~ /^[\$@%]/)
+
+=head3 Options
+
+We use C<option_val()> to look up the current value of the option. If there's
+only a single value, we complete the command in such a way that it is a
+complete command for setting the option in question. If there are multiple
+possible values, we generate a command consisting of the option plus a trailing
+question mark, which, if executed, will list the current value of the option.
+
+=cut
+
+ if ( ( substr $line, 0, $start ) =~ /^\|*[oO]\b.*\s$/ )
+ { # Options after space
+ # We look for the text to be matched in the list of possible options,
+ # and fetch the current value.
+ my @out = grep /^\Q$text/, @options;
+ my $val = option_val( $out[0], undef );
+
+ # Set up a 'query option's value' command.
+ my $out = '? ';
+ if ( not defined $val or $val =~ /[\n\r]/ ) {
+
+ # There's really nothing else we can do.
+ }
+
+ # We have a value. Create a proper option-setting command.
+ elsif ( $val =~ /\s/ ) {
+
+ # XXX This may be an extraneous variable.
+ my $found;
+
+ # We'll want to quote the string (because of the embedded
+ # whtespace), but we want to make sure we don't end up with
+ # mismatched quote characters. We try several possibilities.
+ foreach my $l ( split //, qq/\"\'\#\|/ ) {
+
+ # If we didn't find this quote character in the value,
+ # quote it using this quote character.
+ $out = "$l$val$l ", last if ( index $val, $l ) == -1;
+ }
+ } ## end elsif ($val =~ /\s/)
+
+ # Don't need any quotes.
+ else {
+ $out = "=$val ";
+ }
+
+ # If there were multiple possible values, return '? ', which
+ # makes the command into a query command. If there was just one,
+ # have readline append that.
+ $rl_attribs->{completer_terminator_character} =
+ ( @out == 1 ? $out : '? ' );
+
+ # Return list of possibilities.
+ return sort @out;
+ } ## end if ((substr $line, 0, ...
+
+=head3 Filename completion
+
+For entering filenames. We simply call C<readline>'s C<filename_list()>
+method with the completion text to get the possible completions.
+
+=cut
+
+ return $term->filename_list($text); # filenames
+
+} ## end sub db_complete
+
+=head1 MISCELLANEOUS SUPPORT FUNCTIONS
+
+Functions that possibly ought to be somewhere else.
+
+=head2 end_report
+
+Say we're done.
+
+=cut
+
+sub end_report {
+ local $\ = '';
+ print $OUT "\r\n{\"command\": \"quit\"}\r\n";
+ # print $OUT "Use 'q' to quit or 'R' to restart. 'h q' for details.\r\n";
+}
+
+=head2 clean_ENV
+
+If we have $ini_pids, save it in the environment; else remove it from the
+environment. Used by the C<R> (restart) command.
+
+=cut
+
+sub clean_ENV {
+ if ( defined($ini_pids) ) {
+ $ENV{PERLDB_PIDS} = $ini_pids;
+ }
+ else {
+ delete( $ENV{PERLDB_PIDS} );
+ }
+} ## end sub clean_ENV
+
+# PERLDBf_... flag names from perl.h
+our ( %DollarCaretP_flags, %DollarCaretP_flags_r );
+
+BEGIN {
+ %DollarCaretP_flags = (
+ PERLDBf_SUB => 0x01, # Debug sub enter/exit
+ PERLDBf_LINE => 0x02, # Keep line #
+ PERLDBf_NOOPT => 0x04, # Switch off optimizations
+ PERLDBf_INTER => 0x08, # Preserve more data
+ PERLDBf_SUBLINE => 0x10, # Keep subr source lines
+ PERLDBf_SINGLE => 0x20, # Start with single-step on
+ PERLDBf_NONAME => 0x40, # For _SUB: no name of the subr
+ PERLDBf_GOTO => 0x80, # Report goto: call DB::goto
+ PERLDBf_NAMEEVAL => 0x100, # Informative names for evals
+ PERLDBf_NAMEANON => 0x200, # Informative names for anon subs
+ PERLDBf_SAVESRC => 0x400, # Save source lines into @{"_<$filename"}
+ PERLDB_ALL => 0x33f, # No _NONAME, _GOTO
+ );
+ # PERLDBf_LINE also enables the actions of PERLDBf_SAVESRC, so the debugger
+ # doesn't need to set it. It's provided for the benefit of profilers and
+ # other code analysers.
+
+ %DollarCaretP_flags_r = reverse %DollarCaretP_flags;
+}
+
+sub parse_DollarCaretP_flags {
+ my $flags = shift;
+ $flags =~ s/^\s+//;
+ $flags =~ s/\s+$//;
+ my $acu = 0;
+ foreach my $f ( split /\s*\|\s*/, $flags ) {
+ my $value;
+ if ( $f =~ /^0x([[:xdigit:]]+)$/ ) {
+ $value = hex $1;
+ }
+ elsif ( $f =~ /^(\d+)$/ ) {
+ $value = int $1;
+ }
+ elsif ( $f =~ /^DEFAULT$/i ) {
+ $value = $DollarCaretP_flags{PERLDB_ALL};
+ }
+ else {
+ $f =~ /^(?:PERLDBf_)?(.*)$/i;
+ $value = $DollarCaretP_flags{ 'PERLDBf_' . uc($1) };
+ unless ( defined $value ) {
+ print $OUT (
+ "Unrecognized \$^P flag '$f'!\n",
+ "Acceptable flags are: "
+ . join( ', ', sort keys %DollarCaretP_flags ),
+ ", and hexadecimal and decimal numbers.\r\n"
+ );
+ return undef;
+ }
+ }
+ $acu |= $value;
+ }
+ $acu;
+}
+
+sub expand_DollarCaretP_flags {
+ my $DollarCaretP = shift;
+ my @bits = (
+ map {
+ my $n = ( 1 << $_ );
+ ( $DollarCaretP & $n )
+ ? ( $DollarCaretP_flags_r{$n}
+ || sprintf( '0x%x', $n ) )
+ : ()
+ } 0 .. 31
+ );
+ return @bits ? join( '|', @bits ) : 0;
+}
+
+=over 4
+
+=item rerun
+
+Rerun the current session to:
+
+ rerun current position
+
+ rerun 4 command number 4
+
+ rerun -4 current command minus 4 (go back 4 steps)
+
+Whether this always makes sense, in the current context is unknowable, and is
+in part left as a useful exercise for the reader. This sub returns the
+appropriate arguments to rerun the current session.
+
+=cut
+
+sub rerun {
+ my $i = shift;
+ my @args;
+ pop(@truehist); # strim
+ unless (defined $truehist[$i]) {
+ print "Unable to return to non-existent command: $i\r\n";
+ } else {
+ $#truehist = ($i < 0 ? $#truehist + $i : $i > 0 ? $i : $#truehist);
+ my @temp = @truehist; # store
+ push(@DB::typeahead, @truehist); # saved
+ @truehist = @hist = (); # flush
+ @args = restart(); # setup
+ get_list("PERLDB_HIST"); # clean
+ set_list("PERLDB_HIST", @temp); # reset
+ }
+ return @args;
+}
+
+=item restart
+
+Restarting the debugger is a complex operation that occurs in several phases.
+First, we try to reconstruct the command line that was used to invoke Perl
+and the debugger.
+
+=cut
+
+sub restart {
+ # I may not be able to resurrect you, but here goes ...
+ print $OUT
+"Warning: some settings and command-line options may be lost!\rand\n";
+ my ( @script, @flags, $cl );
+
+ # If warn was on before, turn it on again.
+ push @flags, '-w' if $ini_warn;
+
+ # Rebuild the -I flags that were on the initial
+ # command line.
+ for (@ini_INC) {
+ push @flags, '-I', $_;
+ }
+
+ # Turn on taint if it was on before.
+ push @flags, '-T' if ${^TAINT};
+
+ # Arrange for setting the old INC:
+ # Save the current @init_INC in the environment.
+ set_list( "PERLDB_INC", @ini_INC );
+
+ # If this was a perl one-liner, go to the "file"
+ # corresponding to the one-liner read all the lines
+ # out of it (except for the first one, which is going
+ # to be added back on again when 'perl -d' runs: that's
+ # the 'require perl5db.pl;' line), and add them back on
+ # to the command line to be executed.
+ if ( $0 eq '-e' ) {
+ my $lines = *{$main::{'_<-e'}}{ARRAY};
+ for ( 1 .. $#$lines ) { # The first line is PERL5DB
+ chomp( $cl = $lines->[$_] );
+ push @script, '-e', $cl;
+ }
+ } ## end if ($0 eq '-e')
+
+ # Otherwise we just reuse the original name we had
+ # before.
+ else {
+ @script = $0;
+ }
+
+=pod
+
+After the command line has been reconstructed, the next step is to save
+the debugger's status in environment variables. The C<DB::set_list> routine
+is used to save aggregate variables (both hashes and arrays); scalars are
+just popped into environment variables directly.
+
+=cut
+
+ # If the terminal supported history, grab it and
+ # save that in the environment.
+ set_list( "PERLDB_HIST",
+ $term->Features->{getHistory}
+ ? $term->GetHistory
+ : @hist );
+
+ # Find all the files that were visited during this
+ # session (i.e., the debugger had magic hashes
+ # corresponding to them) and stick them in the environment.
+ my @had_breakpoints = keys %had_breakpoints;
+ set_list( "PERLDB_VISITED", @had_breakpoints );
+
+ # Save the debugger options we chose.
+ set_list( "PERLDB_OPT", %option );
+ # set_list( "PERLDB_OPT", options2remember() );
+
+ # Save the break-on-loads.
+ set_list( "PERLDB_ON_LOAD", %break_on_load );
+
+=pod
+
+The most complex part of this is the saving of all of the breakpoints. They
+can live in an awful lot of places, and we have to go through all of them,
+find the breakpoints, and then save them in the appropriate environment
+variable via C<DB::set_list>.
+
+=cut
+
+ # Go through all the breakpoints and make sure they're
+ # still valid.
+ my @hard;
+ for ( 0 .. $#had_breakpoints ) {
+
+ # We were in this file.
+ my $file = $had_breakpoints[$_];
+
+ # Grab that file's magic line hash.
+ *dbline = $main::{ '_<' . $file };
+
+ # Skip out if it doesn't exist, or if the breakpoint
+ # is in a postponed file (we'll do postponed ones
+ # later).
+ next unless %dbline or $postponed_file{$file};
+
+ # In an eval. This is a little harder, so we'll
+ # do more processing on that below.
+ ( push @hard, $file ), next
+ if $file =~ /^\(\w*eval/;
+
+ # XXX I have no idea what this is doing. Yet.
+ my @add;
+ @add = %{ $postponed_file{$file} }
+ if $postponed_file{$file};
+
+ # Save the list of all the breakpoints for this file.
+ set_list( "PERLDB_FILE_$_", %dbline, @add );
+
+ # Serialize the extra data %breakpoints_data hash.
+ # That's a bug fix.
+ set_list( "PERLDB_FILE_ENABLED_$_",
+ map { _is_breakpoint_enabled($file, $_) ? 1 : 0 }
+ sort { $a <=> $b } keys(%dbline)
+ )
+ } ## end for (0 .. $#had_breakpoints)
+
+ # The breakpoint was inside an eval. This is a little
+ # more difficult. XXX and I don't understand it.
+ foreach my $hard_file (@hard) {
+ # Get over to the eval in question.
+ *dbline = $main::{ '_<' . $hard_file };
+ my $quoted = quotemeta $hard_file;
+ my %subs;
+ for my $sub ( keys %sub ) {
+ if (my ($n1, $n2) = $sub{$sub} =~ /\A$quoted:(\d+)-(\d+)\z/) {
+ $subs{$sub} = [ $n1, $n2 ];
+ }
+ }
+ unless (%subs) {
+ print {$OUT}
+ "No subroutines in $hard_file, ignoring breakpoints.\r\n";
+ next;
+ }
+ LINES: foreach my $line ( keys %dbline ) {
+
+ # One breakpoint per sub only:
+ my ( $offset, $found );
+ SUBS: foreach my $sub ( keys %subs ) {
+ if (
+ $subs{$sub}->[1] >= $line # Not after the subroutine
+ and (
+ not defined $offset # Not caught
+ or $offset < 0
+ )
+ )
+ { # or badly caught
+ $found = $sub;
+ $offset = $line - $subs{$sub}->[0];
+ if ($offset >= 0) {
+ $offset = "+$offset";
+ last SUBS;
+ }
+ } ## end if ($subs{$sub}->[1] >=...
+ } ## end for $sub (keys %subs)
+ if ( defined $offset ) {
+ $postponed{$found} =
+ "break $offset if $dbline{$line}";
+ }
+ else {
+ print {$OUT}
+ ("Breakpoint in ${hard_file}:$line ignored:"
+ . " after all the subroutines.\r\n");
+ }
+ } ## end for $line (keys %dbline)
+ } ## end for (@hard)
+
+ # Save the other things that don't need to be
+ # processed.
+ set_list( "PERLDB_POSTPONE", %postponed );
+ set_list( "PERLDB_PRETYPE", @$pretype );
+ set_list( "PERLDB_PRE", @$pre );
+ set_list( "PERLDB_POST", @$post );
+ set_list( "PERLDB_TYPEAHEAD", @typeahead );
+
+ # We are officially restarting.
+ $ENV{PERLDB_RESTART} = 1;
+
+ # We are junking all child debuggers.
+ delete $ENV{PERLDB_PIDS}; # Restore ini state
+
+ # Set this back to the initial pid.
+ $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids;
+
+=pod
+
+After all the debugger status has been saved, we take the command we built up
+and then return it, so we can C<exec()> it. The debugger will spot the
+C<PERLDB_RESTART> environment variable and realize it needs to reload its state
+from the environment.
+
+=cut
+
+ # And run Perl again. Add the "-d" flag, all the
+ # flags we built up, the script (whether a one-liner
+ # or a file), add on the -emacs flag for a slave editor,
+ # and then the old arguments.
+
+ return ($^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS);
+
+}; # end restart
+
+=back
+
+=head1 END PROCESSING - THE C<END> BLOCK
+
+Come here at the very end of processing. We want to go into a
+loop where we allow the user to enter commands and interact with the
+debugger, but we don't want anything else to execute.
+
+First we set the C<$finished> variable, so that some commands that
+shouldn't be run after the end of program quit working.
+
+We then figure out whether we're truly done (as in the user entered a C<q>
+command, or we finished execution while running nonstop). If we aren't,
+we set C<$single> to 1 (causing the debugger to get control again).
+
+We then call C<DB::fake::at_exit()>, which returns the C<Use 'q' to quit ...>
+message and returns control to the debugger. Repeat.
+
+When the user finally enters a C<q> command, C<$fall_off_end> is set to
+1 and the C<END> block simply exits with C<$single> set to 0 (don't
+break, run to completion.).
+
+=cut
+
+END {
+ $finished = 1 if $inhibit_exit; # So that some commands may be disabled.
+ $fall_off_end = 1 unless $inhibit_exit;
+
+ # Do not stop in at_exit() and destructors on exit:
+ if ($fall_off_end or $runnonstop) {
+ save_hist();
+ } else {
+ $DB::single = 1;
+ DB::fake::at_exit();
+ }
+} ## end END
+
+=head1 PRE-5.8 COMMANDS
+
+Some of the commands changed function quite a bit in the 5.8 command
+realignment, so much so that the old code had to be replaced completely.
+Because we wanted to retain the option of being able to go back to the
+former command set, we moved the old code off to this section.
+
+There's an awful lot of duplicated code here. We've duplicated the
+comments to keep things clear.
+
+=head2 Null command
+
+Does nothing. Used to I<turn off> commands.
+
+=cut
+
+sub cmd_pre580_null {
+
+ # do nothing...
+}
+
+=head2 Old C<a> command.
+
+This version added actions if you supplied them, and deleted them
+if you didn't.
+
+=cut
+
+sub cmd_pre580_a {
+ my $xcmd = shift;
+ my $cmd = shift;
+
+ # Argument supplied. Add the action.
+ if ( $cmd =~ /^(\d*)\s*(.*)/ ) {
+
+ # If the line isn't there, use the current line.
+ my $i = $1 || $line;
+ my $j = $2;
+
+ # If there is an action ...
+ if ( length $j ) {
+
+ # ... but the line isn't breakable, skip it.
+ if ( $dbline[$i] == 0 ) {
+ print $OUT "Line $i may not have an action.\r\n";
+ }
+ else {
+
+ # ... and the line is breakable:
+ # Mark that there's an action in this file.
+ $had_breakpoints{$filename} |= 2;
+
+ # Delete any current action.
+ $dbline{$i} =~ s/\0[^\0]*//;
+
+ # Add the new action, continuing the line as needed.
+ $dbline{$i} .= "\0" . action($j);
+ }
+ } ## end if (length $j)
+
+ # No action supplied.
+ else {
+
+ # Delete the action.
+ $dbline{$i} =~ s/\0[^\0]*//;
+
+ # Mark as having no break or action if nothing's left.
+ delete $dbline{$i} if $dbline{$i} eq '';
+ }
+ } ## end if ($cmd =~ /^(\d*)\s*(.*)/)
+} ## end sub cmd_pre580_a
+
+=head2 Old C<b> command
+
+Add breakpoints.
+
+=cut
+
+sub cmd_pre580_b {
+ my $xcmd = shift;
+ my $cmd = shift;
+ my $dbline = shift;
+
+ # Break on load.
+ if ( $cmd =~ /^load\b\s*(.*)/ ) {
+ my $file = $1;
+ $file =~ s/\s+$//;
+ cmd_b_load($file);
+ }
+
+ # b compile|postpone <some sub> [<condition>]
+ # The interpreter actually traps this one for us; we just put the
+ # necessary condition in the %postponed hash.
+ elsif ( $cmd =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ ) {
+
+ # Capture the condition if there is one. Make it true if none.
+ my $cond = length $3 ? $3 : '1';
+
+ # Save the sub name and set $break to 1 if $1 was 'postpone', 0
+ # if it was 'compile'.
+ my ( $subname, $break ) = ( $2, $1 eq 'postpone' );
+
+ # De-Perl4-ify the name - ' separators to ::.
+ $subname =~ s/\'/::/g;
+
+ # Qualify it into the current package unless it's already qualified.
+ $subname = "${package}::" . $subname
+ unless $subname =~ /::/;
+
+ # Add main if it starts with ::.
+ $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::";
+
+ # Save the break type for this sub.
+ $postponed{$subname} = $break ? "break +0 if $cond" : "compile";
+ } ## end elsif ($cmd =~ ...
+
+ # b <sub name> [<condition>]
+ elsif ( $cmd =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ ) {
+ my $subname = $1;
+ my $cond = length $2 ? $2 : '1';
+ cmd_b_sub( $subname, $cond );
+ }
+ # b <line> [<condition>].
+ elsif ( $cmd =~ /^(\d*)\s*(.*)/ ) {
+ my $i = $1 || $dbline;
+ my $cond = length $2 ? $2 : '1';
+ cmd_b_line( $i, $cond );
+ }
+} ## end sub cmd_pre580_b
+
+=head2 Old C<D> command.
+
+Delete all breakpoints unconditionally.
+
+=cut
+
+sub cmd_pre580_D {
+ my $xcmd = shift;
+ my $cmd = shift;
+ if ( $cmd =~ /^\s*$/ ) {
+ print $OUT "Deleting all breakpoints...\r\n";
+
+ # %had_breakpoints lists every file that had at least one
+ # breakpoint in it.
+ my $file;
+ for $file ( keys %had_breakpoints ) {
+
+ # Switch to the desired file temporarily.
+ local *dbline = $main::{ '_<' . $file };
+
+ $max = $#dbline;
+ my $was;
+
+ # For all lines in this file ...
+ for my $i (1 .. $max) {
+
+ # If there's a breakpoint or action on this line ...
+ if ( defined $dbline{$i} ) {
+
+ # ... remove the breakpoint.
+ $dbline{$i} =~ s/^[^\0]+//;
+ if ( $dbline{$i} =~ s/^\0?$// ) {
+
+ # Remove the entry altogether if no action is there.
+ delete $dbline{$i};
+ }
+ } ## end if (defined $dbline{$i...
+ } ## end for my $i (1 .. $max)
+
+ # If, after we turn off the "there were breakpoints in this file"
+ # bit, the entry in %had_breakpoints for this file is zero,
+ # we should remove this file from the hash.
+ if ( not $had_breakpoints{$file} &= ~1 ) {
+ delete $had_breakpoints{$file};
+ }
+ } ## end for $file (keys %had_breakpoints)
+
+ # Kill off all the other breakpoints that are waiting for files that
+ # haven't been loaded yet.
+ undef %postponed;
+ undef %postponed_file;
+ undef %break_on_load;
+ } ## end if ($cmd =~ /^\s*$/)
+} ## end sub cmd_pre580_D
+
+=head2 Old C<h> command
+
+Print help. Defaults to printing the long-form help; the 5.8 version
+prints the summary by default.
+
+=cut
+
+sub cmd_pre580_h {
+ my $xcmd = shift;
+ my $cmd = shift;
+
+ # Print the *right* help, long format.
+ if ( $cmd =~ /^\s*$/ ) {
+ print_help($pre580_help);
+ }
+
+ # 'h h' - explicitly-requested summary.
+ elsif ( $cmd =~ /^h\s*/ ) {
+ print_help($pre580_summary);
+ }
+
+ # Find and print a command's help.
+ elsif ( $cmd =~ /^h\s+(\S.*)$/ ) {
+ my $asked = $1; # for proper errmsg
+ my $qasked = quotemeta($asked); # for searching
+ # XXX: finds CR but not <CR>
+ if (
+ $pre580_help =~ /^
+ <? # Optional '<'
+ (?:[IB]<) # Optional markup
+ $qasked # The command name
+ /mx
+ )
+ {
+
+ while (
+ $pre580_help =~ /^
+ ( # The command help:
+ <? # Optional '<'
+ (?:[IB]<) # Optional markup
+ $qasked # The command name
+ ([\s\S]*?) # Lines starting with tabs
+ \n # Final newline
+ )
+ (?!\s)/mgx
+ ) # Line not starting with space
+ # (Next command's help)
+ {
+ print_help($1);
+ }
+ } ## end if ($pre580_help =~ /^<?(?:[IB]<)$qasked/m)
+
+ # Help not found.
+ else {
+ print_help("B<$asked> is not a debugger command.\r\n");
+ }
+ } ## end elsif ($cmd =~ /^h\s+(\S.*)$/)
+} ## end sub cmd_pre580_h
+
+=head2 Old C<W> command
+
+C<W E<lt>exprE<gt>> adds a watch expression, C<W> deletes them all.
+
+=cut
+
+sub cmd_pre580_W {
+ my $xcmd = shift;
+ my $cmd = shift;
+
+ # Delete all watch expressions.
+ if ( $cmd =~ /^$/ ) {
+
+ # No watching is going on.
+ $trace &= ~2;
+
+ # Kill all the watch expressions and values.
+ @to_watch = @old_watch = ();
+ }
+
+ # Add a watch expression.
+ elsif ( $cmd =~ /^(.*)/s ) {
+
+ # add it to the list to be watched.
+ push @to_watch, $1;
+
+ # Get the current value of the expression.
+ # Doesn't handle expressions returning list values!
+ $evalarg = $1;
+ # The &-call is here to ascertain the mutability of @_.
+ my ($val) = &DB::eval;
+ $val = ( defined $val ) ? "'$val'" : 'undef';
+
+ # Save it.
+ push @old_watch, $val;
+
+ # We're watching stuff.
+ $trace |= 2;
+
+ } ## end elsif ($cmd =~ /^(.*)/s)
+} ## end sub cmd_pre580_W
+
+=head1 PRE-AND-POST-PROMPT COMMANDS AND ACTIONS
+
+The debugger used to have a bunch of nearly-identical code to handle
+the pre-and-post-prompt action commands. C<cmd_pre590_prepost> and
+C<cmd_prepost> unify all this into one set of code to handle the
+appropriate actions.
+
+=head2 C<cmd_pre590_prepost>
+
+A small wrapper around C<cmd_prepost>; it makes sure that the default doesn't
+do something destructive. In pre 5.8 debuggers, the default action was to
+delete all the actions.
+
+=cut
+
+sub cmd_pre590_prepost {
+ my $cmd = shift;
+ my $line = shift || '*';
+ my $dbline = shift;
+
+ return cmd_prepost( $cmd, $line, $dbline );
+} ## end sub cmd_pre590_prepost
+
+=head2 C<cmd_prepost>
+
+Actually does all the handling for C<E<lt>>, C<E<gt>>, C<{{>, C<{>, etc.
+Since the lists of actions are all held in arrays that are pointed to by
+references anyway, all we have to do is pick the right array reference and
+then use generic code to all, delete, or list actions.
+
+=cut
+
+sub cmd_prepost {
+ my $cmd = shift;
+
+ # No action supplied defaults to 'list'.
+ my $line = shift || '?';
+
+ # Figure out what to put in the prompt.
+ my $which = '';
+
+ # Make sure we have some array or another to address later.
+ # This means that if ssome reason the tests fail, we won't be
+ # trying to stash actions or delete them from the wrong place.
+ my $aref = [];
+
+ # < - Perl code to run before prompt.
+ if ( $cmd =~ /^\</o ) {
+ $which = 'pre-perl';
+ $aref = $pre;
+ }
+
+ # > - Perl code to run after prompt.
+ elsif ( $cmd =~ /^\>/o ) {
+ $which = 'post-perl';
+ $aref = $post;
+ }
+
+ # { - first check for properly-balanced braces.
+ elsif ( $cmd =~ /^\{/o ) {
+ if ( $cmd =~ /^\{.*\}$/o && unbalanced( substr( $cmd, 1 ) ) ) {
+ print $OUT
+"$cmd is now a debugger command\nuse ';$cmd' if you mean Perl code\r\n";
+ }
+
+ # Properly balanced. Pre-prompt debugger actions.
+ else {
+ $which = 'pre-debugger';
+ $aref = $pretype;
+ }
+ } ## end elsif ( $cmd =~ /^\{/o )
+
+ # Did we find something that makes sense?
+ unless ($which) {
+ print $OUT "Confused by command: $cmd\r\n";
+ }
+
+ # Yes.
+ else {
+
+ # List actions.
+ if ( $line =~ /^\s*\?\s*$/o ) {
+ unless (@$aref) {
+
+ # Nothing there. Complain.
+ print $OUT "No $which actions.\r\n";
+ }
+ else {
+
+ # List the actions in the selected list.
+ print $OUT "$which commands:\r\n";
+ foreach my $action (@$aref) {
+ print $OUT "\t$cmd -- $action\r\n";
+ }
+ } ## end else
+ } ## end if ( $line =~ /^\s*\?\s*$/o)
+
+ # Might be a delete.
+ else {
+ if ( length($cmd) == 1 ) {
+ if ( $line =~ /^\s*\*\s*$/o ) {
+
+ # It's a delete. Get rid of the old actions in the
+ # selected list..
+ @$aref = ();
+ print $OUT "All $cmd actions cleared.\r\n";
+ }
+ else {
+
+ # Replace all the actions. (This is a <, >, or {).
+ @$aref = action($line);
+ }
+ } ## end if ( length($cmd) == 1)
+ elsif ( length($cmd) == 2 ) {
+
+ # Add the action to the line. (This is a <<, >>, or {{).
+ push @$aref, action($line);
+ }
+ else {
+
+ # <<<, >>>>, {{{{{{ ... something not a command.
+ print $OUT
+ "Confused by strange length of $which command($cmd)...\r\n";
+ }
+ } ## end else [ if ( $line =~ /^\s*\?\s*$/o)
+ } ## end else
+} ## end sub cmd_prepost
+
+=head1 C<DB::fake>
+
+Contains the C<at_exit> routine that the debugger uses to issue the
+C<Debugged program terminated ...> message after the program completes. See
+the C<END> block documentation for more details.
+
+=cut
+
+package DB::fake;
+
+
+sub at_exit {
+ print $OUT "\r\n{\"command\": \"quit\"}\r\n";
+ # print $OUT "\r\nDebugged program terminated. Use 'q' to quit or 'R' to restart.\r\n";
+}
+
+package DB; # Do not trace this 1; below!
+
+1;
+
+
--- /dev/null
+#!/bin/sh
+#kill process when address already in use
+port=5000
+if [ $# -eq 1 ]
+ then port=$1
+fi
+lsof -iTCP -sTCP:LISTEN -n -P | grep $port | awk '{print $2}'| xargs kill -9
+
--- /dev/null
+Speare Debug Server v0.0.1
+Copyright (c) 2019 sevenuc.com. All rights reserved.
+
+This is the Perl debugger for Speare Pro:
+http://sevenuc.com/en/Speare.html
+
+Package source and download:
+https://github.com/chengdu/Speare
+http://sevenuc.com/download/perl_debugger.tar.gz
+
+Directory Structure:
+
+debugger
+|____Speare # Perl debugger for Perl 5
+| |____dbutil.pl # helper file of the debugger
+| |____perl5db.pl # the main source file of the debugger
+| |____Devel
+| |____Debugger.pm # perl5db.pl wrapper
+|____killproc.sh # shell script to kill Perl process
+|____readme.txt # readme for this package
+
+
+Start Debug Server:
+$ cd ~/Desktop/debugger
+$ perl -I ~/Desktop/debugger/Speare -d:Debugger fullpath.pl
+
+* Warning:
+ fullpath.pl the file must input with full path.
+
+You can directly switch to any Perl interpreter of version 5
+to start a debugging session or use your own self-compiled
+Perl version.
+
+7 Nov 2019
+
--- /dev/null
+#! /usr/bin/env python
+
+# A generic Python debugger for Speare Pro.
+# Copyright (c) 2019 sevenuc.com. All rights reserved.
+#
+# THIS FILE IS PART OF THE ADVANCED VERSION OF SPEARE CODE EDITOR.
+# WITHOUT THE WRITTEN PERMISSION OF THE AUTHOR THIS FILE MAY NOT
+# BE USED FOR ANY COMMERCIAL PRODUCT.
+#
+# More info:
+# http://sevenuc.com/en/Speare.html
+# Contact:
+# Sevenuc support <info@sevenuc.com>
+# Issue report and requests pull:
+# https://github.com/chengdu/Speare
+
+import sys
+import linecache
+import cmd
+import bdb
+
+import os
+import re
+import pprint
+import traceback
+import json
+from repr import Repr
+
+__version__ = '0.0.2'
+
+# Create a custom safe Repr instance and increase its maxstring.
+# The default of 30 truncates error messages too easily.
+_repr = Repr()
+_repr.maxstring = 200
+_saferepr = _repr.repr
+
+class Restart(Exception):
+ """Causes debugger to be restarted for the debugged python program."""
+ pass
+
+__all__ = ["run", "pm", "Debugger", "runeval", "runctx", "runcall", "set_trace",
+ "post_mortem", "help"]
+
+def find_function(funcname, filename):
+ cre = re.compile(r'def\s+%s\s*[(]' % re.escape(funcname))
+ try:
+ fp = open(filename)
+ except IOError:
+ return None
+ # consumer of this info expects the first line to be 1
+ lineno = 1
+ answer = None
+ while 1:
+ line = fp.readline()
+ if line == '':
+ break
+ if cre.match(line):
+ answer = funcname, filename, lineno
+ break
+ lineno = lineno + 1
+ fp.close()
+ return answer
+
+# Interaction prompt line will separate file and call info from code
+# text using value of line_prefix string. A newline and arrow may
+# be to your liking. You can set it once pdb is imported using the
+# command "pdb.line_prefix = '\n% '".
+# line_prefix = ': ' # Use this to get the old situation back
+line_prefix = '\n-> ' # Probably a better default
+
+class Debugger(bdb.Bdb, cmd.Cmd):
+
+ def __init__(self, completekey='tab', stdin=None, stdout=None, skip=None):
+ bdb.Bdb.__init__(self, skip=skip)
+ cmd.Cmd.__init__(self, completekey, stdin, stdout)
+ if stdout:
+ self.use_rawinput = 0
+ self.prompt = ''
+ self.aliases = {}
+ self.mainpyfile = ''
+ self._wait_for_mainpyfile = 0
+ self.sources = []
+ # Try to load readline if it exists
+ try:
+ import readline
+ except ImportError:
+ pass
+
+ # Read $HOME/.pdbrc and ./.pdbrc
+ self.rcLines = []
+ if 'HOME' in os.environ:
+ envHome = os.environ['HOME']
+ try:
+ rcFile = open(os.path.join(envHome, ".pdbrc"))
+ except IOError:
+ pass
+ else:
+ for line in rcFile.readlines():
+ self.rcLines.append(line)
+ rcFile.close()
+ try:
+ rcFile = open(".pdbrc")
+ except IOError:
+ pass
+ else:
+ for line in rcFile.readlines():
+ self.rcLines.append(line)
+ rcFile.close()
+
+ self.commands = {} # associates a command list to breakpoint numbers
+ self.commands_doprompt = {} # for each bp num, tells if the prompt
+ # must be disp. after execing the cmd list
+ self.commands_silent = {} # for each bp num, tells if the stack trace
+ # must be disp. after execing the cmd list
+ self.commands_defining = False # True while in the process of defining
+ # a command list
+ self.commands_bnum = None # The breakpoint number for which we are
+ # defining a list
+
+ def reset(self):
+ bdb.Bdb.reset(self)
+ self.forget()
+
+ def forget(self):
+ self.lineno = None
+ self.stack = []
+ self.curindex = 0
+ self.curframe = None
+
+ def setup(self, f, t):
+ self.forget()
+ self.stack, self.curindex = self.get_stack(f, t)
+ self.curframe = self.stack[self.curindex][0]
+ # The f_locals dictionary is updated from the actual frame
+ # locals whenever the .f_locals accessor is called, so we
+ # cache it here to ensure that modifications are not overwritten.
+ self.curframe_locals = self.curframe.f_locals
+ self.execRcLines()
+
+ # Can be executed earlier than 'setup' if desired
+ def execRcLines(self):
+ if self.rcLines:
+ # Make local copy because of recursion
+ rcLines = self.rcLines
+ # executed only once
+ self.rcLines = []
+ for line in rcLines:
+ line = line[:-1]
+ if len(line) > 0 and line[0] != '#':
+ self.onecmd(line)
+
+ # Override Bdb methods
+ def shouldtrace(self, frame):
+ result = False
+ filename = self.canonic(frame.f_code.co_filename)
+ if not filename in self.excluded_files:
+ dir_path = os.path.dirname(filename)
+ for folder in self.basedirs:
+ if dir_path.startswith(folder):
+ result = True
+ break
+ return result
+
+ def user_call(self, frame, argument_list):
+ """This method is called when there is the remote possibility
+ that we ever need to stop in this function."""
+ if self._wait_for_mainpyfile: return
+ show = self.shouldtrace(frame)
+ filename = self.canonic(frame.f_code.co_filename)
+ if show and not filename in self.sources:
+ self.sources.append(filename)
+ temp = '{ "command": "Paused", "file": "%s", "line": %d }'
+ self.message(temp % (filename, frame.f_lineno))
+ if self.stop_here(frame):
+ #print >>self.stdout, '--Call--'
+ self.interaction(frame, None)
+
+ def user_line(self, frame):
+ """This function is called when we stop or break at this line."""
+ if self._wait_for_mainpyfile:
+ if (self.mainpyfile != self.canonic(frame.f_code.co_filename)
+ or frame.f_lineno<= 0):
+ return
+ self._wait_for_mainpyfile = 0
+ filename = self.canonic(frame.f_code.co_filename)
+ if not filename in self.excluded_files:
+ temp = '{ "command": "Paused", "file": "%s", "line": %d }'
+ self.message(temp % (filename, frame.f_lineno))
+ if self.bp_commands(frame):
+ self.interaction(frame, None)
+
+ def bp_commands(self,frame):
+ """Call every command that was set for the current active breakpoint
+ (if there is one).
+
+ Returns True if the normal interaction function must be called,
+ False otherwise."""
+ # self.currentbp is set in bdb in Bdb.break_here if a breakpoint was hit
+ if getattr(self, "currentbp", False) and \
+ self.currentbp in self.commands:
+ currentbp = self.currentbp
+ self.currentbp = 0
+ lastcmd_back = self.lastcmd
+ self.setup(frame, None)
+ for line in self.commands[currentbp]:
+ self.onecmd(line)
+ self.lastcmd = lastcmd_back
+ if not self.commands_silent[currentbp]:
+ self.print_stack_entry(self.stack[self.curindex])
+ if self.commands_doprompt[currentbp]:
+ self.cmdloop()
+ self.forget()
+ return
+ return 1
+
+ def user_return(self, frame, return_value):
+ """This function is called when a return trap is set here."""
+ if self._wait_for_mainpyfile:
+ return
+ frame.f_locals['__return__'] = return_value
+ #print >>self.stdout, '--Return--'
+ self.interaction(frame, None)
+
+ def user_exception(self, frame, exc_info):
+ """This function is called if an exception occurs,
+ but only if we are to stop at or just below this level."""
+ if self._wait_for_mainpyfile:
+ return
+ exc_type, exc_value, exc_traceback = exc_info
+ frame.f_locals['__exception__'] = exc_type, exc_value
+ if type(exc_type) == type(''): exc_type_name = exc_type
+ else: exc_type_name = exc_type.__name__
+ self.message(exc_type_name + ':', _saferepr(exc_value))
+ self.interaction(frame, exc_traceback)
+ self.onexception()
+
+ # General interaction function
+
+ def interaction(self, frame, traceback):
+ self.setup(frame, traceback)
+ #self.print_stack_entry(self.stack[self.curindex])
+ self.print_stack_variables()
+ self.cmdloop()
+ self.forget()
+
+ def displayhook(self, obj):
+ """Custom displayhook for the exec in default(), which prevents
+ assignment of the _ variable in the builtins.
+ """
+ # reproduce the behavior of the standard displayhook, not printing None
+ if obj is not None:
+ self.message(repr(obj))
+
+ def default(self, line):
+ if line[:1] == '!': line = line[1:]
+ locals = self.curframe_locals
+ globals = self.curframe.f_globals
+ try:
+ code = compile(line + '\n', '<stdin>', 'single')
+ save_stdout = sys.stdout
+ save_stdin = sys.stdin
+ save_displayhook = sys.displayhook
+ try:
+ sys.stdin = self.stdin
+ sys.stdout = self.stdout
+ sys.displayhook = self.displayhook
+ exec(code) in globals, locals
+ finally:
+ sys.stdout = save_stdout
+ sys.stdin = save_stdin
+ sys.displayhook = save_displayhook
+ except:
+ t, v = sys.exc_info()[:2]
+ if type(t) == type(''):
+ exc_type_name = t
+ else: exc_type_name = t.__name__
+ self.message('***', exc_type_name + ':', v)
+
+ def precmd(self, line):
+ """Handle alias expansion and ';;' separator."""
+ if not line.strip():
+ return line
+ args = line.split()
+ while args[0] in self.aliases:
+ line = self.aliases[args[0]]
+ ii = 1
+ for tmpArg in args[1:]:
+ line = line.replace("%" + str(ii),
+ tmpArg)
+ ii = ii + 1
+ line = line.replace("%*", ' '.join(args[1:]))
+ args = line.split()
+ # split into ';;' separated commands
+ # unless it's an alias command
+ if args[0] != 'alias':
+ marker = line.find(';;')
+ if marker >= 0:
+ # queue up everything after marker
+ next = line[marker+2:].lstrip()
+ self.cmdqueue.append(next)
+ line = line[:marker].rstrip()
+ return line
+
+ def onecmd(self, line):
+ """Interpret the argument as though it had been typed in response
+ to the prompt.
+
+ Checks whether this line is typed at the normal prompt or in
+ a breakpoint command list definition.
+ """
+ if not self.commands_defining:
+ return cmd.Cmd.onecmd(self, line)
+ else:
+ return self.handle_command_def(line)
+
+ def handle_command_def(self,line):
+ """Handles one command line during command list definition."""
+ cmd, arg, line = self.parseline(line)
+ if not cmd:
+ return
+ if cmd == 'silent':
+ self.commands_silent[self.commands_bnum] = True
+ return # continue to handle other cmd def in the cmd list
+ elif cmd == 'end':
+ self.cmdqueue = []
+ return 1 # end of cmd list
+ cmdlist = self.commands[self.commands_bnum]
+ if arg:
+ cmdlist.append(cmd+' '+arg)
+ else:
+ cmdlist.append(cmd)
+ # Determine if we must stop
+ try:
+ func = getattr(self, 'do_' + cmd)
+ except AttributeError:
+ func = self.default
+ # one of the resuming commands
+ if func.func_name in self.commands_resuming:
+ self.commands_doprompt[self.commands_bnum] = False
+ self.cmdqueue = []
+ return 1
+ return
+
+ def message(self, *args):
+ print >>self.stdout, " ".join(map(str, args)) + "\r\n"
+
+ # Command definitions, called by cmdloop()
+ # The argument is the remaining string on the command line
+ # Return true to exit from the command loop
+
+ def do_commands(self, arg):
+ """Defines a list of commands associated to a breakpoint.
+
+ Those commands will be executed whenever the breakpoint causes
+ the program to stop execution."""
+ if not arg:
+ bnum = len(bdb.Breakpoint.bpbynumber)-1
+ else:
+ try:
+ bnum = int(arg)
+ except:
+ self.message("Usage : commands [bnum]\n ..." \
+ "\n end")
+ return
+ self.commands_bnum = bnum
+ self.commands[bnum] = []
+ self.commands_doprompt[bnum] = True
+ self.commands_silent[bnum] = False
+ prompt_back = self.prompt
+ self.prompt = '(com) '
+ self.commands_defining = True
+ try:
+ self.cmdloop()
+ finally:
+ self.commands_defining = False
+ self.prompt = prompt_back
+
+ def do_break(self, arg, temporary = 0):
+ # break [ ([filename:]lineno | function) [, "condition"] ]
+ if not arg:
+ if self.breaks: # There's at least one
+ self.message("Num Type Disp Enb Where")
+ for bp in bdb.Breakpoint.bpbynumber:
+ if bp:
+ bp.bpprint(self.stdout)
+ return
+ # parse arguments; comma has lowest precedence
+ # and cannot occur in filename
+ filename = None
+ lineno = None
+ cond = None
+ comma = arg.find(',')
+ if comma > 0:
+ # parse stuff after comma: "condition"
+ cond = arg[comma+1:].lstrip()
+ arg = arg[:comma].rstrip()
+ # parse stuff before comma: [filename:]lineno | function
+ colon = arg.rfind(':')
+ funcname = None
+ if colon >= 0:
+ filename = arg[:colon].rstrip()
+ f = self.lookupmodule(filename)
+ if not f:
+ self.message('*** ', repr(filename), 'not found from sys.path')
+ return
+ else:
+ filename = f
+ arg = arg[colon+1:].lstrip()
+ try:
+ lineno = int(arg)
+ except ValueError as e:
+ self.message('*** Bad lineno:', e)
+ return
+ else:
+ # no colon; can be lineno or function
+ try:
+ lineno = int(arg)
+ except ValueError:
+ try:
+ func = eval(arg,
+ self.curframe.f_globals,
+ self.curframe_locals)
+ except:
+ func = arg
+ try:
+ if hasattr(func, 'im_func'):
+ func = func.im_func
+ code = func.func_code
+ #use co_name to identify the bkpt (function names
+ #could be aliased, but co_name is invariant)
+ funcname = code.co_name
+ lineno = code.co_firstlineno
+ filename = code.co_filename
+ except:
+ # last thing to try
+ (ok, filename, ln) = self.lineinfo(arg)
+ if not ok:
+ self.message('*** The specified object', \
+ repr(arg), \
+ 'is not a function' \
+ 'or was not found along sys.path.')
+ return
+ funcname = ok # ok contains a function name
+ lineno = int(ln)
+ if not filename:
+ filename = self.defaultFile()
+ # Check for reasonable breakpoint
+ line = self.checkline(filename, lineno)
+ if line:
+ # now set the break point
+ err = self.set_break(filename, line, temporary, cond, funcname)
+ if err: self.message('***', err)
+ else:
+ bp = self.get_breaks(filename, line)[-1]
+ #print >>self.stdout, "Breakpoint %d at %s:%d" % (bp.number, bp.file, bp.line)
+ temp = '{ "command": "Breakpoint", "id": %d, "file": "%s", "line": %d }'
+ self.message(temp % (bp.number, bp.file, bp.line))
+
+ # To be overridden in derived debuggers
+ def defaultFile(self):
+ """Produce a reasonable default."""
+ filename = self.curframe.f_code.co_filename
+ if filename == '<string>' and self.mainpyfile:
+ filename = self.mainpyfile
+ return filename
+
+ do_b = do_break
+
+ def do_tbreak(self, arg):
+ self.do_break(arg, 1)
+
+ def lineinfo(self, identifier):
+ failed = (None, None, None)
+ # Input is identifier, may be in single quotes
+ idstring = identifier.split("'")
+ if len(idstring) == 1:
+ # not in single quotes
+ id = idstring[0].strip()
+ elif len(idstring) == 3:
+ # quoted
+ id = idstring[1].strip()
+ else:
+ return failed
+ if id == '': return failed
+ parts = id.split('.')
+ # Protection for derived debuggers
+ if parts[0] == 'self':
+ del parts[0]
+ if len(parts) == 0:
+ return failed
+ # Best first guess at file to look at
+ fname = self.defaultFile()
+ if len(parts) == 1:
+ item = parts[0]
+ else:
+ # More than one part.
+ # First is module, second is method/class
+ f = self.lookupmodule(parts[0])
+ if f:
+ fname = f
+ item = parts[1]
+ answer = find_function(item, fname)
+ return answer or failed
+
+ def checkline(self, filename, lineno):
+ """Check whether specified line seems to be executable.
+
+ Return `lineno` if it is, 0 if not (e.g. a docstring, comment, blank
+ line or EOF). Warning: testing is not comprehensive.
+ """
+ # this method should be callable before starting debugging, so default
+ # to "no globals" if there is no current frame
+ globs = self.curframe.f_globals if hasattr(self, 'curframe') else None
+ line = linecache.getline(filename, lineno, globs)
+ if not line:
+ self.message('End of file')
+ return 0
+ line = line.strip()
+ # Don't allow setting breakpoint at a blank line
+ if (not line or (line[0] == '#') or
+ (line[:3] == '"""') or line[:3] == "'''"):
+ self.message('*** Blank or comment')
+ return 0
+ return lineno
+
+ def do_enable(self, arg):
+ args = arg.split()
+ for i in args:
+ try:
+ i = int(i)
+ except ValueError:
+ self.message('Breakpoint index %r is not a number' % i)
+ continue
+
+ if not (0 <= i < len(bdb.Breakpoint.bpbynumber)):
+ self.message('No breakpoint numbered', i)
+ continue
+
+ bp = bdb.Breakpoint.bpbynumber[i]
+ if bp:
+ bp.enable()
+
+ def do_disable(self, arg):
+ args = arg.split()
+ for i in args:
+ try:
+ i = int(i)
+ except ValueError:
+ self.message('Breakpoint index %r is not a number' % i)
+ continue
+
+ if not (0 <= i < len(bdb.Breakpoint.bpbynumber)):
+ self.message('No breakpoint numbered', i)
+ continue
+
+ bp = bdb.Breakpoint.bpbynumber[i]
+ if bp:
+ bp.disable()
+
+ def do_condition(self, arg):
+ # arg is breakpoint number and condition
+ args = arg.split(' ', 1)
+ try:
+ bpnum = int(args[0].strip())
+ except ValueError:
+ # something went wrong
+ self.message('Breakpoint index %r is not a number' % args[0])
+ return
+ try:
+ cond = args[1]
+ except:
+ cond = None
+ try:
+ bp = bdb.Breakpoint.bpbynumber[bpnum]
+ except IndexError:
+ self.message('Breakpoint index %r is not valid' % args[0])
+ return
+ if bp:
+ bp.cond = cond
+ if not cond:
+ self.message('Breakpoint', bpnum, 'is now unconditional.')
+
+ def do_ignore(self,arg):
+ """arg is bp number followed by ignore count."""
+ args = arg.split()
+ try:
+ bpnum = int(args[0].strip())
+ except ValueError:
+ # something went wrong
+ self.message('Breakpoint index %r is not a number' % args[0])
+ return
+ try:
+ count = int(args[1].strip())
+ except:
+ count = 0
+ try:
+ bp = bdb.Breakpoint.bpbynumber[bpnum]
+ except IndexError:
+ self.message('Breakpoint index %r is not valid' % args[0])
+ return
+ if bp:
+ bp.ignore = count
+ if count > 0:
+ reply = 'Will ignore next '
+ if count > 1:
+ reply = reply + '%d crossings' % count
+ else:
+ reply = reply + '1 crossing'
+ self.message(reply + ' of breakpoint %d.' % bpnum)
+ else:
+ self.message('Will stop next time breakpoint', bpnum, 'is reached.')
+
+ def do_clear(self, arg):
+ if not arg:
+ self.clear_all_breaks()
+ return
+ if ':' in arg:
+ # Make sure it works for "clear C:\foo\bar.py:12"
+ i = arg.rfind(':')
+ filename = arg[:i]
+ arg = arg[i+1:]
+ try:
+ lineno = int(arg)
+ except ValueError:
+ err = "Invalid line number (%s)" % arg
+ else:
+ err = self.clear_break(filename, lineno)
+ if err: self.message('***', err)
+ return
+ numberlist = arg.split()
+ for i in numberlist:
+ try:
+ i = int(i)
+ except ValueError:
+ self.message('Breakpoint index %r is not a number' % i)
+ continue
+
+ if not (0 <= i < len(bdb.Breakpoint.bpbynumber)):
+ self.message('No breakpoint numbered', i)
+ continue
+ err = self.clear_bpbynumber(i)
+ if err:
+ self.message('***', err)
+ else:
+ self.message('Deleted breakpoint', i)
+
+ do_cl = do_clear # 'c' is already an abbreviation for 'continue'
+
+ def do_where(self, arg):
+ self.print_stack_trace()
+ do_w = do_where
+ do_bt = do_where
+
+ def do_up(self, arg):
+ if self.curindex == 0:
+ self.message('*** Oldest frame')
+ else:
+ self.curindex = self.curindex - 1
+ self.curframe = self.stack[self.curindex][0]
+ self.curframe_locals = self.curframe.f_locals
+ self.print_stack_entry(self.stack[self.curindex])
+ self.lineno = None
+ do_u = do_up
+
+ def do_down(self, arg):
+ if self.curindex + 1 == len(self.stack):
+ self.message('*** Newest frame')
+ else:
+ self.curindex = self.curindex + 1
+ self.curframe = self.stack[self.curindex][0]
+ self.curframe_locals = self.curframe.f_locals
+ self.print_stack_entry(self.stack[self.curindex])
+ self.lineno = None
+ do_d = do_down
+
+ def do_until(self, arg):
+ self.set_until(self.curframe)
+ return 1
+ do_unt = do_until
+
+ def do_step(self, arg):
+ frame = self.stack[self.curindex][0]
+ if self.shouldtrace(frame):
+ filename = self.canonic(frame.f_code.co_filename)
+ if not filename in self.sources:
+ self.sources.append(filename)
+ self.set_trace(frame)
+ self.set_step()
+ return 1
+ do_s = do_step
+
+ def do_next(self, arg):
+ self.set_next(self.curframe)
+ return 1
+ do_n = do_next
+
+ def do_run(self, arg):
+ if arg:
+ import shlex
+ argv0 = sys.argv[0:1]
+ sys.argv = shlex.split(arg)
+ sys.argv[:0] = argv0
+ raise Restart
+
+ do_restart = do_run
+
+ def do_return(self, arg):
+ self.set_return(self.curframe)
+ return 1
+ do_r = do_return
+
+ def do_continue(self, arg):
+ self.set_continue()
+ return 1
+ do_c = do_cont = do_continue
+
+ def do_jump(self, arg):
+ if self.curindex + 1 != len(self.stack):
+ self.message("*** You can only jump within the bottom frame")
+ return
+ try:
+ arg = int(arg)
+ except ValueError:
+ self.message("*** The 'jump' command requires a line number.")
+ else:
+ try:
+ # Do the jump, fix up our copy of the stack, and display the
+ # new position
+ self.curframe.f_lineno = arg
+ self.stack[self.curindex] = self.stack[self.curindex][0], arg
+ self.print_stack_entry(self.stack[self.curindex])
+ except ValueError, e:
+ self.message('*** Jump failed:', e)
+ do_j = do_jump
+
+ def do_debug(self, arg):
+ sys.settrace(None)
+ globals = self.curframe.f_globals
+ locals = self.curframe_locals
+ p = Debugger(self.completekey, self.stdin, self.stdout)
+ p.prompt = "(%s) " % self.prompt.strip()
+ self.message("ENTERING RECURSIVE DEBUGGER")
+ sys.call_tracing(p.run, (arg, globals, locals))
+ self.message("LEAVING RECURSIVE DEBUGGER")
+ sys.settrace(self.trace_dispatch)
+ self.lastcmd = p.lastcmd
+
+ def do_quit(self, arg):
+ self._user_requested_quit = 1
+ self.set_quit()
+ return 1
+
+ do_q = do_quit
+ do_exit = do_quit
+
+ def do_EOF(self, arg):
+ print >>self.stdout
+ self._user_requested_quit = 1
+ self.set_quit()
+ return 1
+
+ def do_args(self, arg):
+ co = self.curframe.f_code
+ dict = self.curframe_locals
+ n = co.co_argcount
+ if co.co_flags & 4: n = n+1
+ if co.co_flags & 8: n = n+1
+ for i in range(n):
+ name = co.co_varnames[i]
+ if name in dict: val = dict[name]
+ else: val = "*** undefined ***"
+ self.message('%s = %s' % (name, val))
+ do_a = do_args
+
+ def do_retval(self, arg):
+ if '__return__' in self.curframe_locals:
+ self.message(self.curframe_locals['__return__'])
+ else:
+ self.message('*** Not yet returned!')
+ do_rv = do_retval
+
+ def do_basedir(self, arg):
+ if os.path.isdir(arg) and not arg in self.basedirs:
+ self.basedirs.append(arg)
+ sys.path.insert(0, arg)
+ self.message('%s added in sys.path.' % arg)
+ else: self.message('*** %s is not a directory or already added.' % arg)
+
+ def do_load(self, arg):
+ pdir = os.path.dirname(arg)
+ if not sys.path[0] == pdir: sys.path.insert(0, pdir)
+ try:
+ self.message('%s will be loaded.' % arg)
+ self._runscript(arg)
+ except:
+ t, v = sys.exc_info()[:2]
+ if isinstance(t, str):
+ exc_type_name = t
+ else: exc_type_name = t.__name__
+ self.message('***', exc_type_name + ':', repr(v))
+ raise
+
+ def do_eval(self, arg):
+ #retval = self.runeval(expr)
+ #if not isinstance(arg, types.CodeType): arg = arg+'\n'
+ #try: retval = eval(arg, globals, locals)
+ #except:
+ # t, v = sys.exc_info()[:2]
+ # if isinstance(t, str): exc_type_name = t
+ # else: exc_type_name = t.__name__
+ # print('*** %s: %s %s' % (arg, exc_type_name + ':', repr(v)))
+ #if not retval: return
+ #temp = '{ "command": "Expression", "eval": "%s", "result": "%s" }'
+ #print >>self.stdout, temp % (arg, str(retval))
+ pass
+
+ def _getval(self, arg):
+ try:
+ return eval(arg, self.curframe.f_globals,
+ self.curframe_locals)
+ except:
+ t, v = sys.exc_info()[:2]
+ if isinstance(t, str):
+ exc_type_name = t
+ else: exc_type_name = t.__name__
+ self.message('***', exc_type_name + ':', repr(v))
+ raise
+
+ def do_p(self, arg):
+ try:
+ self.message(repr(self._getval(arg)))
+ except:
+ pass
+
+ def do_pp(self, arg):
+ try:
+ pprint.pprint(self._getval(arg), self.stdout)
+ except:
+ pass
+
+ def do_whatis(self, arg):
+ try:
+ value = eval(arg, self.curframe.f_globals,
+ self.curframe_locals)
+ except:
+ t, v = sys.exc_info()[:2]
+ if type(t) == type(''):
+ exc_type_name = t
+ else: exc_type_name = t.__name__
+ self.message('***', exc_type_name + ':', repr(v))
+ return
+ code = None
+ # Is it a function?
+ try: code = value.func_code
+ except: pass
+ if code:
+ self.message('Function', code.co_name)
+ return
+ # Is it an instance method?
+ try: code = value.im_func.func_code
+ except: pass
+ if code:
+ self.message('Method', code.co_name)
+ return
+ # None of the above...
+ self.message(type(value))
+
+ def do_alias(self, arg):
+ args = arg.split()
+ if len(args) == 0:
+ keys = self.aliases.keys()
+ keys.sort()
+ for alias in keys:
+ self.message("%s = %s" % (alias, self.aliases[alias]))
+ return
+ if args[0] in self.aliases and len(args) == 1:
+ self.message("%s = %s" % (args[0], self.aliases[args[0]]))
+ else:
+ self.aliases[args[0]] = ' '.join(args[1:])
+
+ def do_unalias(self, arg):
+ args = arg.split()
+ if len(args) == 0: return
+ if args[0] in self.aliases:
+ del self.aliases[args[0]]
+
+ def onexception(self):
+ pass
+
+ #list of all the commands making the program resume execution.
+ commands_resuming = ['do_continue', 'do_step', 'do_next', 'do_return',
+ 'do_quit', 'do_jump']
+
+ # Print a traceback starting at the top stack frame.
+ # The most recently entered frame is printed last;
+ # this is different from dbx and gdb, but consistent with
+ # the Python interpreter's stack trace.
+ # It is also consistent with the up/down commands (which are
+ # compatible with dbx and gdb: up moves towards 'main()'
+ # and down moves towards the most recent stack frame).
+
+ def print_stack_trace(self):
+ try:
+ for frame_lineno in self.stack:
+ self.print_stack_entry(frame_lineno)
+ except KeyboardInterrupt:
+ pass
+
+ def print_stack_entry(self, frame_lineno, prompt_prefix=line_prefix):
+ frame, lineno = frame_lineno
+ filename = self.canonic(frame.f_code.co_filename)
+ if filename in self.excluded_files: return
+ if frame is self.curframe: print('>')
+ else: print(' ')
+ print(self.format_stack_entry(frame_lineno, prompt_prefix))
+
+ def viewstack(self, data):
+ """
+ Dumps data related to a referenced event to the socket.
+ """
+ try:
+ dumped = json.dumps({"command": "stack", "data": data}).encode("utf-8")
+ self.message(dumped)
+ except OSError as e:
+ pass
+ except AttributeError as e:
+ pass
+
+ def print_stack_variables(self):
+ """
+ Dump the current stack.
+
+ If this is a normal situation, the top two frames are BDB and the
+ Debugger executing the program. If there is an exception, there are two
+ further extra frames. All these frames can be ignored.
+ """
+ stack_data = []
+ for frame, line_no in self.stack:
+ filename = self.canonic(frame.f_code.co_filename)
+ if filename in self.excluded_files: continue
+ frame_data = (
+ line_no,
+ {
+ "filename": frame.f_code.co_filename,
+ "locals": {
+ k: repr(v) for k, v in frame.f_locals.items()
+ },
+ #"globals": {
+ # k: repr(v) for k, v in frame.f_globals.items()
+ #},
+ #"builtins": {
+ # k: repr(v) for k, v in frame.f_builtins.items()
+ #},
+ #"restricted": getattr(frame, "f_restricted", ""),
+ #"lasti": repr(frame.f_lasti),
+ #"exc_type": repr(getattr(frame, "f_exc_type", "")),
+ #"exc_value": repr(getattr(frame, "f_exc_value", "")),
+ #"exc_traceback": repr(
+ # getattr(frame, "f_exc_traceback", "")
+ #),
+ "current": frame is self.curframe,
+ },
+ )
+ stack_data.append(frame_data)
+
+ locals_dict = {}
+ excluded_names = ["globals", "locals", "built-in", "__builtins__", \
+ "__debug_code__", "__debug_script__"]
+ for frame in stack_data:
+ for k, v in frame[1]["locals"].items():
+ if k in excluded_names: continue
+ if not v.startswith("<module") and not v.startswith("execfile("):
+ locals_dict[k] = v
+ self.viewstack(locals_dict)
+
+ def lookupmodule(self, filename):
+ """Helper function for break/clear parsing -- may be overridden.
+
+ lookupmodule() translates (possibly incomplete) file or module name
+ into an absolute file name.
+ """
+ if os.path.isabs(filename) and os.path.exists(filename):
+ return filename
+ f = os.path.join(sys.path[0], filename)
+ if os.path.exists(f) and self.canonic(f) == self.mainpyfile:
+ return f
+ root, ext = os.path.splitext(filename)
+ if ext == '':
+ filename = filename + '.py'
+ if os.path.isabs(filename):
+ return filename
+ for dirname in sys.path:
+ while os.path.islink(dirname):
+ dirname = os.readlink(dirname)
+ fullname = os.path.join(dirname, filename)
+ if os.path.exists(fullname):
+ return fullname
+ return None
+
+ def _runscript(self, filename):
+ # The script has to run in __main__ namespace (or imports from
+ # __main__ will break).
+ #
+ # So we clear up the __main__ and set several special variables
+ # (this gets rid of pdb's globals and cleans old variables on restarts).
+
+ import __main__
+ __main__.__dict__.clear()
+ __main__.__dict__.update({"__name__" : "__main__",
+ "__file__" : filename,
+ "__builtins__": __builtins__,
+ })
+
+ # When bdb sets tracing, a number of call and line events happens
+ # BEFORE debugger even reaches user's code (and the exact sequence of
+ # events depends on python version). So we take special measures to
+ # avoid stopping before we reach the main script (see user_line and
+ # user_call for details).
+ self._wait_for_mainpyfile = 1
+ self.mainpyfile = self.canonic(filename)
+ self._user_requested_quit = 0 # should exit the process
+ statement = 'execfile(%r)' % filename
+ self.run(statement)
+
+# Simplified interface
+
+def run(statement, globals=None, locals=None):
+ Debugger().run(statement, globals, locals)
+
+def runeval(expression, globals=None, locals=None):
+ return Debugger().runeval(expression, globals, locals)
+
+def runctx(statement, globals, locals):
+ # B/W compatibility
+ run(statement, globals, locals)
+
+def runcall(*args, **kwds):
+ return Debugger().runcall(*args, **kwds)
+
+def set_trace():
+ Debugger().set_trace(sys._getframe().f_back)
+
+# Post-Mortem interface
+def post_mortem(t=None):
+ # handling the default
+ if t is None:
+ # sys.exc_info() returns (type, value, traceback) if an exception is
+ # being handled, otherwise it returns None
+ t = sys.exc_info()[2]
+ if t is None:
+ raise ValueError("A valid traceback must be passed if no "
+ "exception is being handled")
+ p = Debugger()
+ p.reset()
+ p.interaction(None, t)
+
+def pm():
+ post_mortem(sys.last_traceback)
+
--- /dev/null
+#! /usr/bin/env python
+
+# A generic Python debugger for Speare Pro.
+# Copyright (c) 2019 sevenuc.com. All rights reserved.
+#
+# THIS FILE IS PART OF THE ADVANCED VERSION OF SPEARE CODE EDITOR.
+# WITHOUT THE WRITTEN PERMISSION OF THE AUTHOR THIS FILE MAY NOT
+# BE USED FOR ANY COMMERCIAL PRODUCT.
+#
+# More info:
+# http://sevenuc.com/en/Speare.html
+# Contact:
+# Sevenuc support <info@sevenuc.com>
+# Issue report and requests pull:
+# https://github.com/chengdu/Speare
+
+from __future__ import print_function
+import errno
+import os
+import re
+import socket
+import sys
+from debugger import Debugger
+
+__version__ = '0.0.2'
+def info(message, stderr=sys.__stderr__):
+ print(message, file=stderr)
+ stderr.flush()
+
+class SocketHandle(object):
+ def __init__(self, connection):
+ self.connection = connection
+ self.stream = fh = connection.makefile('rw')
+ self.read = fh.read
+ self.readline = fh.readline
+ self.readlines = fh.readlines
+ self.close = fh.close
+ self.flush = fh.flush
+ self.fileno = fh.fileno
+ if hasattr(fh, 'encoding'):
+ self._send = lambda data: connection.sendall(data.encode(fh.encoding))
+ else:
+ self._send = connection.sendall
+
+ @property
+ def encoding(self):
+ return self.stream.encoding
+
+ def __iter__(self):
+ return self.stream.__iter__()
+
+ def write(self, data, nl_rex=re.compile("\r?\n")):
+ data = nl_rex.sub("\r\n", data)
+ self._send(data)
+
+ def writelines(self, lines, nl_rex=re.compile("\r?\n")):
+ for line in lines:
+ self.write(line, nl_rex)
+ self.stream.flush()
+
+class Debugstub(Debugger):
+ active_instance = None
+
+ def __init__(self, sock, connection):
+ self._quiet = False
+ patch_stdstreams=False
+ self.sock = sock
+ self.connection = connection
+ self.handle = SocketHandle(connection)
+ Debugger.__init__(self, completekey='tab', stdin=self.handle, stdout=self.handle)
+ self.backup = []
+ if patch_stdstreams:
+ for name in (
+ 'stderr',
+ 'stdout',
+ '__stderr__',
+ '__stdout__',
+ 'stdin',
+ '__stdin__',
+ ):
+ self.backup.append((name, getattr(sys, name)))
+ setattr(sys, name, self.handle)
+ Debugstub.active_instance = self
+
+ def release_sock(self):
+ info('*** socket released.')
+ if self.connection: self.connection.close()
+ if self.sock: self.sock.close()
+
+ def onexception(self):
+ self.release_sock()
+
+ def __restore(self):
+ if self.backup and not self._quiet:
+ info('*** Restoring streams: %s ...' % self.backup)
+ for name, fh in self.backup:
+ setattr(sys, name, fh)
+ self.release_sock()
+ self.handle.close()
+ Debugstub.active_instance = None
+
+ def do_quit(self, arg):
+ self.__restore()
+ return Debugger.do_quit(self, arg)
+
+ do_q = do_exit = do_quit
+
+ def set_trace(self, frame=None):
+ if frame is None:
+ frame = sys._getframe().f_back
+ try:
+ Debugger.set_trace(self, frame)
+ except IOError as exc:
+ if exc.errno != errno.ECONNRESET:
+ raise
+
--- /dev/null
+#! /usr/bin/env python
+
+# A generic Python debugger for Speare Pro.
+# Copyright (c) 2019 sevenuc.com. All rights reserved.
+#
+# THIS FILE IS PART OF THE ADVANCED VERSION OF SPEARE CODE EDITOR.
+# WITHOUT THE WRITTEN PERMISSION OF THE AUTHOR THIS FILE MAY NOT
+# BE USED FOR ANY COMMERCIAL PRODUCT.
+#
+# More info:
+# http://sevenuc.com/en/Speare.html
+# Contact:
+# Sevenuc support <info@sevenuc.com>
+# Issue report and requests pull:
+# https://github.com/chengdu/Speare
+
+import os
+import sys
+import codecs
+import signal
+import socket
+from bdb import BdbQuit
+from debugstub import Debugstub
+
+port = 4444
+__version__ = '0.0.2'
+if (sys.version_info.major != 2):
+ print("Wrong Python version!")
+ sys.exit(0)
+
+reload(sys)
+sys.setdefaultencoding('utf-8')
+
+def printbanner():
+ print("\n")
+ print(" ____")
+ print(" / __/ __ ___ ___ ___ ___")
+ print(" _\\ \\/ _ \\/ -_) _ `/ __/ -_)")
+ print(" /___/ .__/\\__/\\_,_/_/ \\__/")
+ print(" /_/")
+ print("Speare Debug Server v1.0")
+ print("(c) http://sevenuc.com \n")
+
+def startDebugger(sock, connection, port, filename):
+ print('Start debugging session on: %s' % filename)
+ base = os.path.dirname(filename)
+ sys.path.insert(0, base)
+ signal.signal(signal.SIGTTOU, signal.SIG_IGN)
+ dbs = Debugstub(sock, connection)
+ dir_path = os.path.dirname(os.path.realpath(__file__))
+ files = ["debugger.py", "debugstub.py", "server.py"]
+ dbs.excluded_files = map(lambda x: os.path.join(dir_path, x), files)
+ dbs.set_trace()
+ dbs.basedirs = []
+ dbs.basedirs.append(base)
+ dbs._runscript(filename)
+
+if len(sys.argv) == 2:
+ try: port = int(sys.argv[1])
+ except:
+ print('*** invalid port number: "%s".' % sys.argv[1])
+ sys.exit(0)
+
+sock = socket.socket(socket.AF_INET, socket.SOCK_STREAM)
+server_address = ('localhost', port)
+sock.bind(server_address) # Address already in use
+sock.listen(1) # Listen for incoming connection
+filename = None
+printbanner()
+print('Listen on port %d ...' % port)
+connection, client_address = sock.accept()
+#connection.setsockopt(socket.IPPROTO_TCP, socket.TCP_NODELAY, 1)
+while True:
+ data = connection.recv(1024) # Receive the startup script
+ filename = data.decode('utf-8').strip('\r\n')
+ if filename.startswith("b'"): filename = filename[2:-2]
+ break
+try:
+ if filename: startDebugger(sock, connection, port, filename)
+ else: print("*** can't get a script to start debugging session.")
+finally:
+ if connection: connection.close()
+ if sock: sock.close()
+
--- /dev/null
+#! /usr/bin/env python3
+
+# A generic Python debugger for Speare Pro.
+# Copyright (c) 2019 sevenuc.com. All rights reserved.
+#
+# THIS FILE IS PART OF THE ADVANCED VERSION OF SPEARE CODE EDITOR.
+# WITHOUT THE WRITTEN PERMISSION OF THE AUTHOR THIS FILE MAY NOT
+# BE USED FOR ANY COMMERCIAL PRODUCT.
+#
+# More info:
+# http://sevenuc.com/en/Speare.html
+# Contact:
+# Sevenuc support <info@sevenuc.com>
+# Issue report and requests pull:
+# https://github.com/chengdu/Speare
+
+import os
+import re
+import sys
+import cmd
+import bdb
+import dis
+import code
+import glob
+import pprint
+import signal
+import inspect
+import traceback
+import linecache
+import json
+
+__version__ = '0.0.2'
+class Restart(Exception):
+ """Causes a debugger to be restarted for the debugged python program."""
+ pass
+
+__all__ = ["run", "pm", "Debugger", "runeval", "runctx", "runcall", "set_trace",
+ "post_mortem", "help"]
+
+def find_function(funcname, filename):
+ cre = re.compile(r'def\s+%s\s*[(]' % re.escape(funcname))
+ try:
+ fp = open(filename)
+ except OSError:
+ return None
+ # consumer of this info expects the first line to be 1
+ with fp:
+ for lineno, line in enumerate(fp, start=1):
+ if cre.match(line):
+ return funcname, filename, lineno
+ return None
+
+def getsourcelines(obj):
+ lines, lineno = inspect.findsource(obj)
+ if inspect.isframe(obj) and obj.f_globals is obj.f_locals:
+ # must be a module frame: do not try to cut a block out of it
+ return lines, 1
+ elif inspect.ismodule(obj):
+ return lines, 1
+ return inspect.getblock(lines[lineno:]), lineno+1
+
+def lasti2lineno(code, lasti):
+ linestarts = list(dis.findlinestarts(code))
+ linestarts.reverse()
+ for i, lineno in linestarts:
+ if lasti >= i:
+ return lineno
+ return 0
+
+class _rstr(str):
+ """String that doesn't quote its repr."""
+ def __repr__(self):
+ return self
+
+# Interaction prompt line will separate file and call info from code
+# text using value of line_prefix string. A newline and arrow may
+# be to your liking. You can set it once pdb is imported using the
+# command "pdb.line_prefix = '\n% '".
+# line_prefix = ': ' # Use this to get the old situation back
+line_prefix = '\n-> ' # Probably a better default
+
+class Debugger(bdb.Bdb, cmd.Cmd):
+
+ def __init__(self, completekey='tab', stdin=None, stdout=None, skip=None,
+ nosigint=False):
+ bdb.Bdb.__init__(self, skip=skip)
+ cmd.Cmd.__init__(self, completekey, stdin, stdout)
+ if stdout:
+ self.use_rawinput = 0
+ self.prompt = ''
+ self.aliases = {}
+ self.displaying = {}
+ self.mainpyfile = ''
+ self._wait_for_mainpyfile = False
+ self.tb_lineno = {}
+ self.sources = []
+ # Try to load readline if it exists
+ try:
+ import readline
+ # remove some common file name delimiters
+ readline.set_completer_delims(' \t\n`@#$%^&*()=+[{]}\\|;:\'",<>?')
+ except ImportError:
+ pass
+ self.allow_kbdint = False
+ self.nosigint = nosigint
+
+ # Read $HOME/.pdbrc and ./.pdbrc
+ self.rcLines = []
+ if 'HOME' in os.environ:
+ envHome = os.environ['HOME']
+ try:
+ with open(os.path.join(envHome, ".pdbrc")) as rcFile:
+ self.rcLines.extend(rcFile)
+ except OSError:
+ pass
+ try:
+ with open(".pdbrc") as rcFile:
+ self.rcLines.extend(rcFile)
+ except OSError:
+ pass
+
+ self.commands = {} # associates a command list to breakpoint numbers
+ self.commands_doprompt = {} # for each bp num, tells if the prompt
+ # must be disp. after execing the cmd list
+ self.commands_silent = {} # for each bp num, tells if the stack trace
+ # must be disp. after execing the cmd list
+ self.commands_defining = False # True while in the process of defining
+ # a command list
+ self.commands_bnum = None # The breakpoint number for which we are
+ # defining a list
+
+ def sigint_handler(self, signum, frame):
+ if self.allow_kbdint:
+ raise KeyboardInterrupt
+ self.message("\nProgram interrupted. (Use 'cont' to resume).")
+ self.set_step()
+ self.set_trace(frame)
+ # restore previous signal handler
+ signal.signal(signal.SIGINT, self._previous_sigint_handler)
+
+ def reset(self):
+ bdb.Bdb.reset(self)
+ self.forget()
+
+ def forget(self):
+ self.lineno = None
+ self.stack = []
+ self.curindex = 0
+ self.curframe = None
+ self.tb_lineno.clear()
+
+ def setup(self, f, tb):
+ self.forget()
+ self.stack, self.curindex = self.get_stack(f, tb)
+ while tb:
+ # when setting up post-mortem debugging with a traceback, save all
+ # the original line numbers to be displayed along the current line
+ # numbers (which can be different, e.g. due to finally clauses)
+ lineno = lasti2lineno(tb.tb_frame.f_code, tb.tb_lasti)
+ self.tb_lineno[tb.tb_frame] = lineno
+ tb = tb.tb_next
+ self.curframe = self.stack[self.curindex][0]
+ # The f_locals dictionary is updated from the actual frame
+ # locals whenever the .f_locals accessor is called, so we
+ # cache it here to ensure that modifications are not overwritten.
+ self.curframe_locals = self.curframe.f_locals
+ return self.execRcLines()
+
+ # Can be executed earlier than 'setup' if desired
+ def execRcLines(self):
+ if not self.rcLines:
+ return
+ # local copy because of recursion
+ rcLines = self.rcLines
+ rcLines.reverse()
+ # execute every line only once
+ self.rcLines = []
+ while rcLines:
+ line = rcLines.pop().strip()
+ if line and line[0] != '#':
+ if self.onecmd(line):
+ # if onecmd returns True, the command wants to exit
+ # from the interaction, save leftover rc lines
+ # to execute before next interaction
+ self.rcLines += reversed(rcLines)
+ return True
+
+ # Override Bdb methods
+ def shouldtrace(self, frame):
+ result = False
+ filename = self.canonic(frame.f_code.co_filename)
+ if not filename in self.excluded_files:
+ dir_path = os.path.dirname(filename)
+ for folder in self.basedirs:
+ if dir_path.startswith(folder):
+ result = True
+ break
+ return result
+
+ def user_call(self, frame, argument_list):
+ """This method is called when there is the remote possibility
+ that we ever need to stop in this function."""
+ if self._wait_for_mainpyfile: return
+ show = self.shouldtrace(frame)
+ filename = self.canonic(frame.f_code.co_filename)
+ if show and not filename in self.sources:
+ self.sources.append(filename)
+ temp = '{"command": "Paused", "file": "%s", "line": %d}'
+ self.message(temp % (filename, frame.f_lineno))
+ if self.stop_here(frame):
+ #self.message('--Call--')
+ self.interaction(frame, None)
+
+ def user_line(self, frame):
+ """This function is called when we stop or break at this line."""
+ if self._wait_for_mainpyfile:
+ if (self.mainpyfile != self.canonic(frame.f_code.co_filename)
+ or frame.f_lineno <= 0):
+ return
+ self._wait_for_mainpyfile = False
+ filename = self.canonic(frame.f_code.co_filename)
+ if not filename in self.excluded_files:
+ temp = '{"command": "Paused", "file": "%s", "line": %d}'
+ self.message(temp % (filename, frame.f_lineno))
+ if self.bp_commands(frame):
+ self.interaction(frame, None)
+
+ def bp_commands(self, frame):
+ """Call every command that was set for the current active breakpoint
+ (if there is one).
+
+ Returns True if the normal interaction function must be called,
+ False otherwise."""
+ # self.currentbp is set in bdb in Bdb.break_here if a breakpoint was hit
+ if getattr(self, "currentbp", False) and \
+ self.currentbp in self.commands:
+ currentbp = self.currentbp
+ self.currentbp = 0
+ lastcmd_back = self.lastcmd
+ self.setup(frame, None)
+ for line in self.commands[currentbp]:
+ self.onecmd(line)
+ self.lastcmd = lastcmd_back
+ if not self.commands_silent[currentbp]:
+ self.print_stack_entry(self.stack[self.curindex])
+ if self.commands_doprompt[currentbp]:
+ self._cmdloop()
+ self.forget()
+ return
+ return 1
+
+ def user_return(self, frame, return_value):
+ """This function is called when a return trap is set here."""
+ if self._wait_for_mainpyfile:
+ return
+ frame.f_locals['__return__'] = return_value
+ #self.message('--Return--')
+ self.interaction(frame, None)
+
+ def user_exception(self, frame, exc_info):
+ """This function is called if an exception occurs,
+ but only if we are to stop at or just below this level."""
+ if self._wait_for_mainpyfile:
+ return
+ exc_type, exc_value, exc_traceback = exc_info
+ frame.f_locals['__exception__'] = exc_type, exc_value
+
+ # An 'Internal StopIteration' exception is an exception debug event
+ # issued by the interpreter when handling a subgenerator run with
+ # 'yield from' or a generator controlled by a for loop. No exception has
+ # actually occurred in this case. The debugger uses this debug event to
+ # stop when the debuggee is returning from such generators.
+ prefix = 'Internal ' if (not exc_traceback
+ and exc_type is StopIteration) else ''
+ self.message('%s%s' % (prefix,
+ traceback.format_exception_only(exc_type, exc_value)[-1].strip()))
+ self.interaction(frame, exc_traceback)
+
+ # General interaction function
+ def _cmdloop(self):
+ while True:
+ try:
+ # keyboard interrupts allow for an easy way to cancel
+ # the current command, so allow them during interactive input
+ self.allow_kbdint = True
+ self.cmdloop()
+ self.allow_kbdint = False
+ break
+ except KeyboardInterrupt:
+ print('--KeyboardInterrupt--')
+
+ # Called before loop, handles display expressions
+ def preloop(self):
+ displaying = self.displaying.get(self.curframe)
+ if displaying:
+ for expr, oldvalue in displaying.items():
+ newvalue = self._getval_except(expr)
+ # check for identity first; this prevents custom __eq__ to
+ # be called at every loop, and also prevents instances whose
+ # fields are changed to be displayed
+ if newvalue is not oldvalue and newvalue != oldvalue:
+ displaying[expr] = newvalue
+ self.message('display %s: %r [old: %r]' %
+ (expr, newvalue, oldvalue))
+
+ def interaction(self, frame, traceback):
+ if self.setup(frame, traceback):
+ # no interaction desired at this time (happens if .pdbrc contains
+ # a command like "continue")
+ self.forget()
+ return
+ #self.print_stack_entry(self.stack[self.curindex])
+ self.print_stack_variables()
+ self._cmdloop()
+ self.forget()
+
+ def displayhook(self, obj):
+ """Custom displayhook for the exec in default(), which prevents
+ assignment of the _ variable in the builtins.
+ """
+ # reproduce the behavior of the standard displayhook, not printing None
+ if obj is not None:
+ self.message(repr(obj))
+
+ def default(self, line):
+ if line[:1] == '!': line = line[1:]
+ locals = self.curframe_locals
+ globals = self.curframe.f_globals
+ try:
+ code = compile(line + '\n', '<stdin>', 'single')
+ save_stdout = sys.stdout
+ save_stdin = sys.stdin
+ save_displayhook = sys.displayhook
+ try:
+ sys.stdin = self.stdin
+ sys.stdout = self.stdout
+ sys.displayhook = self.displayhook
+ exec(code, globals, locals)
+ finally:
+ sys.stdout = save_stdout
+ sys.stdin = save_stdin
+ sys.displayhook = save_displayhook
+ except:
+ exc_info = sys.exc_info()[:2]
+ self.error(traceback.format_exception_only(*exc_info)[-1].strip())
+
+ def precmd(self, line):
+ """Handle alias expansion and ';;' separator."""
+ if not line.strip():
+ return line
+ args = line.split()
+ while args[0] in self.aliases:
+ line = self.aliases[args[0]]
+ ii = 1
+ for tmpArg in args[1:]:
+ line = line.replace("%" + str(ii),
+ tmpArg)
+ ii += 1
+ line = line.replace("%*", ' '.join(args[1:]))
+ args = line.split()
+ # split into ';;' separated commands
+ # unless it's an alias command
+ if args[0] != 'alias':
+ marker = line.find(';;')
+ if marker >= 0:
+ # queue up everything after marker
+ next = line[marker+2:].lstrip()
+ self.cmdqueue.append(next)
+ line = line[:marker].rstrip()
+ return line
+
+ def onecmd(self, line):
+ """Interpret the argument as though it had been typed in response
+ to the prompt.
+
+ Checks whether this line is typed at the normal prompt or in
+ a breakpoint command list definition.
+ """
+ if not self.commands_defining:
+ return cmd.Cmd.onecmd(self, line)
+ else:
+ return self.handle_command_def(line)
+
+ def handle_command_def(self, line):
+ """Handles one command line during command list definition."""
+ cmd, arg, line = self.parseline(line)
+ if not cmd:
+ return
+ if cmd == 'silent':
+ self.commands_silent[self.commands_bnum] = True
+ return # continue to handle other cmd def in the cmd list
+ elif cmd == 'end':
+ self.cmdqueue = []
+ return 1 # end of cmd list
+ cmdlist = self.commands[self.commands_bnum]
+ if arg:
+ cmdlist.append(cmd+' '+arg)
+ else:
+ cmdlist.append(cmd)
+ # Determine if we must stop
+ try:
+ func = getattr(self, 'do_' + cmd)
+ except AttributeError:
+ func = self.default
+ # one of the resuming commands
+ if func.__name__ in self.commands_resuming:
+ self.commands_doprompt[self.commands_bnum] = False
+ self.cmdqueue = []
+ return 1
+ return
+
+ # interface abstraction functions
+ def message(self, msg):
+ pass
+
+ def error(self, msg):
+ if msg == 'SyntaxError: invalid syntax':
+ return
+ print('***', msg, file=self.stdout)
+ print('\r\n', file=self.stdout)
+
+ # Generic completion functions. Individual complete_foo methods can be
+ # assigned below to one of these functions.
+
+ def _complete_location(self, text, line, begidx, endidx):
+ # Complete a file/module/function location for break/tbreak/clear.
+ if line.strip().endswith((':', ',')):
+ # Here comes a line number or a condition which we can't complete.
+ return []
+ # First, try to find matching functions (i.e. expressions).
+ try:
+ ret = self._complete_expression(text, line, begidx, endidx)
+ except Exception:
+ ret = []
+ # Then, try to complete file names as well.
+ globs = glob.glob(text + '*')
+ for fn in globs:
+ if os.path.isdir(fn):
+ ret.append(fn + '/')
+ elif os.path.isfile(fn) and fn.lower().endswith(('.py', '.pyw')):
+ ret.append(fn + ':')
+ return ret
+
+ def _complete_bpnumber(self, text, line, begidx, endidx):
+ # Complete a breakpoint number. (This would be more helpful if we could
+ # display additional info along with the completions, such as file/line
+ # of the breakpoint.)
+ return [str(i) for i, bp in enumerate(bdb.Breakpoint.bpbynumber)
+ if bp is not None and str(i).startswith(text)]
+
+ def _complete_expression(self, text, line, begidx, endidx):
+ # Complete an arbitrary expression.
+ if not self.curframe:
+ return []
+ # Collect globals and locals. It is usually not really sensible to also
+ # complete builtins, and they clutter the namespace quite heavily, so we
+ # leave them out.
+ ns = self.curframe.f_globals.copy()
+ ns.update(self.curframe_locals)
+ if '.' in text:
+ # Walk an attribute chain up to the last part, similar to what
+ # rlcompleter does. This will bail if any of the parts are not
+ # simple attribute access, which is what we want.
+ dotted = text.split('.')
+ try:
+ obj = ns[dotted[0]]
+ for part in dotted[1:-1]:
+ obj = getattr(obj, part)
+ except (KeyError, AttributeError):
+ return []
+ prefix = '.'.join(dotted[:-1]) + '.'
+ return [prefix + n for n in dir(obj) if n.startswith(dotted[-1])]
+ else:
+ # Complete a simple name.
+ return [n for n in ns.keys() if n.startswith(text)]
+
+ # Command definitions, called by cmdloop()
+ # The argument is the remaining string on the command line
+ # Return true to exit from the command loop
+
+ def do_commands(self, arg):
+ """commands [bpnumber]
+ (com) ...
+ (com) end
+ """
+ if not arg:
+ bnum = len(bdb.Breakpoint.bpbynumber) - 1
+ else:
+ try:
+ bnum = int(arg)
+ except:
+ self.error("Usage: commands [bnum]\n ...\n end")
+ return
+ self.commands_bnum = bnum
+ # Save old definitions for the case of a keyboard interrupt.
+ if bnum in self.commands:
+ old_command_defs = (self.commands[bnum],
+ self.commands_doprompt[bnum],
+ self.commands_silent[bnum])
+ else:
+ old_command_defs = None
+ self.commands[bnum] = []
+ self.commands_doprompt[bnum] = True
+ self.commands_silent[bnum] = False
+
+ prompt_back = self.prompt
+ self.prompt = '(com) '
+ self.commands_defining = True
+ try:
+ self.cmdloop()
+ except KeyboardInterrupt:
+ # Restore old definitions.
+ if old_command_defs:
+ self.commands[bnum] = old_command_defs[0]
+ self.commands_doprompt[bnum] = old_command_defs[1]
+ self.commands_silent[bnum] = old_command_defs[2]
+ else:
+ del self.commands[bnum]
+ del self.commands_doprompt[bnum]
+ del self.commands_silent[bnum]
+ self.error('command definition aborted, old commands restored')
+ finally:
+ self.commands_defining = False
+ self.prompt = prompt_back
+
+ complete_commands = _complete_bpnumber
+
+ def do_break(self, arg, temporary = 0):
+ """b(reak) [ ([filename:]lineno | function) [, condition] ]
+ """
+ if not arg:
+ if self.breaks: # There's at least one
+ self.message("Num Type Disp Enb Where")
+ for bp in bdb.Breakpoint.bpbynumber:
+ if bp:
+ self.message(bp.bpformat())
+ return
+ # parse arguments; comma has lowest precedence
+ # and cannot occur in filename
+ filename = None
+ lineno = None
+ cond = None
+ comma = arg.find(',')
+ if comma > 0:
+ # parse stuff after comma: "condition"
+ cond = arg[comma+1:].lstrip()
+ arg = arg[:comma].rstrip()
+ # parse stuff before comma: [filename:]lineno | function
+ colon = arg.rfind(':')
+ funcname = None
+ if colon >= 0:
+ filename = arg[:colon].rstrip()
+ f = self.lookupmodule(filename)
+ if not f:
+ self.error('%r not found from sys.path' % filename)
+ return
+ else:
+ filename = f
+ arg = arg[colon+1:].lstrip()
+ try:
+ lineno = int(arg)
+ except ValueError:
+ self.error('Bad lineno: %s' % arg)
+ return
+ else:
+ # no colon; can be lineno or function
+ try:
+ lineno = int(arg)
+ except ValueError:
+ try:
+ func = eval(arg,
+ self.curframe.f_globals,
+ self.curframe_locals)
+ except:
+ func = arg
+ try:
+ if hasattr(func, '__func__'):
+ func = func.__func__
+ code = func.__code__
+ #use co_name to identify the bkpt (function names
+ #could be aliased, but co_name is invariant)
+ funcname = code.co_name
+ lineno = code.co_firstlineno
+ filename = code.co_filename
+ except:
+ # last thing to try
+ (ok, filename, ln) = self.lineinfo(arg)
+ if not ok:
+ self.error('The specified object %r is not a function '
+ 'or was not found along sys.path.' % arg)
+ return
+ funcname = ok # ok contains a function name
+ lineno = int(ln)
+ if not filename:
+ filename = self.defaultFile()
+ # Check for reasonable breakpoint
+ line = self.checkline(filename, lineno)
+ if line:
+ # now set the break point
+ err = self.set_break(filename, line, temporary, cond, funcname)
+ if err:
+ self.error(err)
+ else:
+ bp = self.get_breaks(filename, line)[-1]
+ temp = '{ "command": "Breakpoint", "id": %d, "file": "%s", "line": %d }'
+ self.message(temp % (bp.number, bp.file, bp.line))
+
+ # To be overridden in derived debuggers
+ def defaultFile(self):
+ """Produce a reasonable default."""
+ filename = self.curframe.f_code.co_filename
+ if filename == '<string>' and self.mainpyfile:
+ filename = self.mainpyfile
+ return filename
+
+ do_b = do_break
+
+ complete_break = _complete_location
+ complete_b = _complete_location
+
+ def do_tbreak(self, arg):
+ """tbreak [ ([filename:]lineno | function) [, condition] ]
+ Same arguments as break, but sets a temporary breakpoint: it
+ is automatically deleted when first hit.
+ """
+ self.do_break(arg, 1)
+
+ complete_tbreak = _complete_location
+
+ def lineinfo(self, identifier):
+ failed = (None, None, None)
+ # Input is identifier, may be in single quotes
+ idstring = identifier.split("'")
+ if len(idstring) == 1:
+ # not in single quotes
+ id = idstring[0].strip()
+ elif len(idstring) == 3:
+ # quoted
+ id = idstring[1].strip()
+ else:
+ return failed
+ if id == '': return failed
+ parts = id.split('.')
+ # Protection for derived debuggers
+ if parts[0] == 'self':
+ del parts[0]
+ if len(parts) == 0:
+ return failed
+ # Best first guess at file to look at
+ fname = self.defaultFile()
+ if len(parts) == 1:
+ item = parts[0]
+ else:
+ # More than one part.
+ # First is module, second is method/class
+ f = self.lookupmodule(parts[0])
+ if f:
+ fname = f
+ item = parts[1]
+ answer = find_function(item, fname)
+ return answer or failed
+
+ def checkline(self, filename, lineno):
+ """Check whether specified line seems to be executable.
+
+ Return `lineno` if it is, 0 if not (e.g. a docstring, comment, blank
+ line or EOF). Warning: testing is not comprehensive.
+ """
+ # this method should be callable before starting debugging, so default
+ # to "no globals" if there is no current frame
+ globs = self.curframe.f_globals if hasattr(self, 'curframe') else None
+ line = linecache.getline(filename, lineno, globs)
+ if not line:
+ self.message('End of file')
+ return 0
+ line = line.strip()
+ # Don't allow setting breakpoint at a blank line
+ if (not line or (line[0] == '#') or
+ (line[:3] == '"""') or line[:3] == "'''"):
+ self.error('Blank or comment')
+ return 0
+ return lineno
+
+ def do_enable(self, arg):
+ args = arg.split()
+ for i in args:
+ try:
+ bp = self.get_bpbynumber(i)
+ except ValueError as err:
+ self.error(err)
+ else:
+ bp.enable()
+ self.message('Enabled %s' % bp)
+
+ complete_enable = _complete_bpnumber
+
+ def do_disable(self, arg):
+ args = arg.split()
+ for i in args:
+ try:
+ bp = self.get_bpbynumber(i)
+ except ValueError as err:
+ self.error(err)
+ else:
+ bp.disable()
+ self.message('Disabled %s' % bp)
+
+ complete_disable = _complete_bpnumber
+
+ def do_condition(self, arg):
+ args = arg.split(' ', 1)
+ try:
+ cond = args[1]
+ except IndexError:
+ cond = None
+ try:
+ bp = self.get_bpbynumber(args[0].strip())
+ except IndexError:
+ self.error('Breakpoint number expected')
+ except ValueError as err:
+ self.error(err)
+ else:
+ bp.cond = cond
+ if not cond:
+ self.message('Breakpoint %d is now unconditional.' % bp.number)
+ else:
+ self.message('New condition set for breakpoint %d.' % bp.number)
+
+ complete_condition = _complete_bpnumber
+
+ def do_ignore(self, arg):
+ """ignore bpnumber [count]
+ """
+ args = arg.split()
+ try:
+ count = int(args[1].strip())
+ except:
+ count = 0
+ try:
+ bp = self.get_bpbynumber(args[0].strip())
+ except IndexError:
+ self.error('Breakpoint number expected')
+ except ValueError as err:
+ self.error(err)
+ else:
+ bp.ignore = count
+ if count > 0:
+ if count > 1:
+ countstr = '%d crossings' % count
+ else:
+ countstr = '1 crossing'
+ self.message('Will ignore next %s of breakpoint %d.' %
+ (countstr, bp.number))
+ else:
+ self.message('Will stop next time breakpoint %d is reached.'
+ % bp.number)
+
+ complete_ignore = _complete_bpnumber
+
+ def do_clear(self, arg):
+ if not arg:
+ bplist = [bp for bp in bdb.Breakpoint.bpbynumber if bp]
+ self.clear_all_breaks()
+ for bp in bplist:
+ self.message('Deleted %s' % bp)
+ return
+ if ':' in arg:
+ # Make sure it works for "clear C:\foo\bar.py:12"
+ i = arg.rfind(':')
+ filename = arg[:i]
+ arg = arg[i+1:]
+ try:
+ lineno = int(arg)
+ except ValueError:
+ err = "Invalid line number (%s)" % arg
+ else:
+ bplist = self.get_breaks(filename, lineno)
+ err = self.clear_break(filename, lineno)
+ if err:
+ self.error(err)
+ else:
+ for bp in bplist:
+ self.message('Deleted %s' % bp)
+ return
+ numberlist = arg.split()
+ for i in numberlist:
+ try:
+ bp = self.get_bpbynumber(i)
+ except ValueError as err:
+ self.error(err)
+ else:
+ self.clear_bpbynumber(i)
+ self.message('Deleted %s' % bp)
+ do_cl = do_clear # 'c' is already an abbreviation for 'continue'
+
+ complete_clear = _complete_location
+ complete_cl = _complete_location
+
+ def do_where(self, arg):
+ self.print_stack_trace()
+ do_w = do_where
+ do_bt = do_where
+
+ def _select_frame(self, number):
+ assert 0 <= number < len(self.stack)
+ self.curindex = number
+ self.curframe = self.stack[self.curindex][0]
+ self.curframe_locals = self.curframe.f_locals
+ self.print_stack_entry(self.stack[self.curindex])
+ self.lineno = None
+
+ def do_up(self, arg):
+ if self.curindex == 0:
+ self.error('Oldest frame')
+ return
+ try:
+ count = int(arg or 1)
+ except ValueError:
+ self.error('Invalid frame count (%s)' % arg)
+ return
+ if count < 0:
+ newframe = 0
+ else:
+ newframe = max(0, self.curindex - count)
+ self._select_frame(newframe)
+ do_u = do_up
+
+ def do_down(self, arg):
+ if self.curindex + 1 == len(self.stack):
+ self.error('Newest frame')
+ return
+ try:
+ count = int(arg or 1)
+ except ValueError:
+ self.error('Invalid frame count (%s)' % arg)
+ return
+ if count < 0:
+ newframe = len(self.stack) - 1
+ else:
+ newframe = min(len(self.stack) - 1, self.curindex + count)
+ self._select_frame(newframe)
+ do_d = do_down
+
+ def do_until(self, arg):
+ if arg:
+ try:
+ lineno = int(arg)
+ except ValueError:
+ self.error('Error in argument: %r' % arg)
+ return
+ if lineno <= self.curframe.f_lineno:
+ self.error('"until" line number is smaller than current '
+ 'line number')
+ return
+ else:
+ lineno = None
+ self.set_until(self.curframe, lineno)
+ return 1
+ do_unt = do_until
+
+ def do_step(self, arg):
+ self.set_step()
+ return 1
+ do_s = do_step
+
+ def do_next(self, arg):
+ self.set_next(self.curframe)
+ return 1
+ do_n = do_next
+
+ def do_run(self, arg):
+ if arg:
+ import shlex
+ argv0 = sys.argv[0:1]
+ sys.argv = shlex.split(arg)
+ sys.argv[:0] = argv0
+ # this is caught in the main debugger loop
+ raise Restart
+
+ do_restart = do_run
+
+ def do_return(self, arg):
+ self.set_return(self.curframe)
+ return 1
+ do_r = do_return
+
+ def do_continue(self, arg):
+ if not self.nosigint:
+ try:
+ self._previous_sigint_handler = \
+ signal.signal(signal.SIGINT, self.sigint_handler)
+ except ValueError:
+ # ValueError happens when do_continue() is invoked from
+ # a non-main thread in which case we just continue without
+ # SIGINT set. Would printing a message here (once) make
+ # sense?
+ pass
+ self.set_continue()
+ return 1
+ do_c = do_cont = do_continue
+
+ def do_jump(self, arg):
+ if self.curindex + 1 != len(self.stack):
+ self.error('You can only jump within the bottom frame')
+ return
+ try:
+ arg = int(arg)
+ except ValueError:
+ self.error("The 'jump' command requires a line number")
+ else:
+ try:
+ # Do the jump, fix up our copy of the stack, and display the
+ # new position
+ self.curframe.f_lineno = arg
+ self.stack[self.curindex] = self.stack[self.curindex][0], arg
+ self.print_stack_entry(self.stack[self.curindex])
+ except ValueError as e:
+ self.error('Jump failed: %s' % e)
+ do_j = do_jump
+
+ def do_debug(self, arg):
+ sys.settrace(None)
+ globals = self.curframe.f_globals
+ locals = self.curframe_locals
+ p = Pdb(self.completekey, self.stdin, self.stdout)
+ p.prompt = "(%s) " % self.prompt.strip()
+ self.message("ENTERING RECURSIVE DEBUGGER")
+ sys.call_tracing(p.run, (arg, globals, locals))
+ self.message("LEAVING RECURSIVE DEBUGGER")
+ sys.settrace(self.trace_dispatch)
+ self.lastcmd = p.lastcmd
+
+ complete_debug = _complete_expression
+
+ def do_quit(self, arg):
+ self._user_requested_quit = True
+ self.set_quit()
+ return 1
+
+ do_q = do_quit
+ do_exit = do_quit
+
+ def do_EOF(self, arg):
+ self.message('')
+ self._user_requested_quit = True
+ self.set_quit()
+ return 1
+
+ def do_args(self, arg):
+ co = self.curframe.f_code
+ dict = self.curframe_locals
+ n = co.co_argcount
+ if co.co_flags & 4: n = n+1
+ if co.co_flags & 8: n = n+1
+ for i in range(n):
+ name = co.co_varnames[i]
+ if name in dict:
+ self.message('%s = %r' % (name, dict[name]))
+ else:
+ self.message('%s = *** undefined ***' % (name,))
+ do_a = do_args
+
+ def do_retval(self, arg):
+ if '__return__' in self.curframe_locals:
+ self.message(repr(self.curframe_locals['__return__']))
+ else:
+ self.error('Not yet returned!')
+ do_rv = do_retval
+
+ def _getval(self, arg):
+ try:
+ return eval(arg, self.curframe.f_globals, self.curframe_locals)
+ except:
+ exc_info = sys.exc_info()[:2]
+ self.error(traceback.format_exception_only(*exc_info)[-1].strip())
+ raise
+
+ def _getval_except(self, arg, frame=None):
+ try:
+ if frame is None:
+ return eval(arg, self.curframe.f_globals, self.curframe_locals)
+ else:
+ return eval(arg, frame.f_globals, frame.f_locals)
+ except:
+ exc_info = sys.exc_info()[:2]
+ err = traceback.format_exception_only(*exc_info)[-1].strip()
+ return _rstr('** raised %s **' % err)
+
+ def do_p(self, arg):
+ try:
+ self.message(repr(self._getval(arg)))
+ except:
+ pass
+
+ def do_pp(self, arg):
+ try:
+ self.message(pprint.pformat(self._getval(arg)))
+ except:
+ pass
+
+ complete_print = _complete_expression
+ complete_p = _complete_expression
+ complete_pp = _complete_expression
+
+ def do_source(self, arg):
+ try:
+ obj = self._getval(arg)
+ except:
+ return
+ try:
+ lines, lineno = getsourcelines(obj)
+ except (OSError, TypeError) as err:
+ self.error(err)
+ return
+ self._print_lines(lines, lineno)
+
+ complete_source = _complete_expression
+
+ def _print_lines(self, lines, start, breaks=(), frame=None):
+ """Print a range of lines."""
+ if frame:
+ current_lineno = frame.f_lineno
+ exc_lineno = self.tb_lineno.get(frame, -1)
+ else:
+ current_lineno = exc_lineno = -1
+ for lineno, line in enumerate(lines, start):
+ s = str(lineno).rjust(3)
+ if len(s) < 4:
+ s += ' '
+ if lineno in breaks:
+ s += 'B'
+ else:
+ s += ' '
+ if lineno == current_lineno:
+ s += '->'
+ elif lineno == exc_lineno:
+ s += '>>'
+ self.message(s + '\t' + line.rstrip())
+
+ def do_whatis(self, arg):
+ """whatis arg
+ Print the type of the argument.
+ """
+ try:
+ value = self._getval(arg)
+ except:
+ # _getval() already printed the error
+ return
+ code = None
+ # Is it a function?
+ try:
+ code = value.__code__
+ except Exception:
+ pass
+ if code:
+ self.message('Function %s' % code.co_name)
+ return
+ # Is it an instance method?
+ try:
+ code = value.__func__.__code__
+ except Exception:
+ pass
+ if code:
+ self.message('Method %s' % code.co_name)
+ return
+ # Is it a class?
+ if value.__class__ is type:
+ self.message('Class %s.%s' % (value.__module__, value.__qualname__))
+ return
+ # None of the above...
+ self.message(type(value))
+
+ complete_whatis = _complete_expression
+
+ def do_display(self, arg):
+ if not arg:
+ self.message('Currently displaying:')
+ for item in self.displaying.get(self.curframe, {}).items():
+ self.message('%s: %r' % item)
+ else:
+ val = self._getval_except(arg)
+ self.displaying.setdefault(self.curframe, {})[arg] = val
+ self.message('display %s: %r' % (arg, val))
+
+ complete_display = _complete_expression
+
+ def do_undisplay(self, arg):
+ if arg:
+ try:
+ del self.displaying.get(self.curframe, {})[arg]
+ except KeyError:
+ self.error('not displaying %s' % arg)
+ else:
+ self.displaying.pop(self.curframe, None)
+
+ def complete_undisplay(self, text, line, begidx, endidx):
+ return [e for e in self.displaying.get(self.curframe, {})
+ if e.startswith(text)]
+
+ def do_interact(self, arg):
+ ns = self.curframe.f_globals.copy()
+ ns.update(self.curframe_locals)
+ code.interact("*interactive*", local=ns)
+
+ def do_alias(self, arg):
+ args = arg.split()
+ if len(args) == 0:
+ keys = sorted(self.aliases.keys())
+ for alias in keys:
+ self.message("%s = %s" % (alias, self.aliases[alias]))
+ return
+ if args[0] in self.aliases and len(args) == 1:
+ self.message("%s = %s" % (args[0], self.aliases[args[0]]))
+ else:
+ self.aliases[args[0]] = ' '.join(args[1:])
+
+ def do_unalias(self, arg):
+ args = arg.split()
+ if len(args) == 0: return
+ if args[0] in self.aliases:
+ del self.aliases[args[0]]
+
+ def do_basedir(self, arg):
+ if os.path.isdir(arg) and not arg in self.basedirs:
+ self.basedirs.append(arg)
+ sys.path.insert(0, arg)
+ self.message('%s added in sys.path.' % arg)
+ else: self.message('*** %s is not a directory or already added.' % arg)
+
+ def complete_unalias(self, text, line, begidx, endidx):
+ return [a for a in self.aliases if a.startswith(text)]
+
+ # List of all the commands making the program resume execution.
+ commands_resuming = ['do_continue', 'do_step', 'do_next', 'do_return',
+ 'do_quit', 'do_jump']
+
+ # Print a traceback starting at the top stack frame.
+ # The most recently entered frame is printed last;
+ # this is different from dbx and gdb, but consistent with
+ # the Python interpreter's stack trace.
+ # It is also consistent with the up/down commands (which are
+ # compatible with dbx and gdb: up moves towards 'main()'
+ # and down moves towards the most recent stack frame).
+
+ def print_stack_trace(self):
+ try:
+ for frame_lineno in self.stack:
+ self.print_stack_entry(frame_lineno)
+ except KeyboardInterrupt:
+ pass
+
+ def print_stack_entry(self, frame_lineno, prompt_prefix=line_prefix):
+ frame, lineno = frame_lineno
+ if frame is self.curframe:prefix = '> '
+ else: prefix = ' '
+ self.message(prefix + self.format_stack_entry(frame_lineno, prompt_prefix))
+
+ def viewstack(self, data):
+ """
+ Dumps data related to a referenced event to the socket.
+ """
+ try:
+ dumped = json.dumps({"command": "stack", "data": data})
+ dumped = dumped.replace("u\'","\'") # get rid of backslashes
+ self.message(dumped)
+ except OSError as e:
+ pass
+ except AttributeError as e:
+ pass
+
+ def print_stack_variables(self):
+ """
+ Dump the current stack.
+
+ If this is a normal situation, the top two frames are BDB and the
+ Debugger executing the program. If there is an exception, there are two
+ further extra frames. All these frames can be ignored.
+ """
+ stack_data = []
+ for frame, line_no in self.stack:
+ filename = self.canonic(frame.f_code.co_filename)
+ if filename in self.excluded_files: continue
+ frame_data = (
+ line_no,
+ {
+ "filename": frame.f_code.co_filename,
+ "locals": {
+ k: repr(v) for k, v in frame.f_locals.items()
+ },
+ #"globals": {
+ # k: repr(v) for k, v in frame.f_globals.items()
+ #},
+ #"builtins": {
+ # k: repr(v) for k, v in frame.f_builtins.items()
+ #},
+ #"restricted": getattr(frame, "f_restricted", ""),
+ #"lasti": repr(frame.f_lasti),
+ #"exc_type": repr(getattr(frame, "f_exc_type", "")),
+ #"exc_value": repr(getattr(frame, "f_exc_value", "")),
+ #"exc_traceback": repr(
+ # getattr(frame, "f_exc_traceback", "")
+ #),
+ "current": frame is self.curframe,
+ },
+ )
+ stack_data.append(frame_data)
+
+ locals_dict = {}
+ excluded_names = ["globals", "locals", "statement", "built-in", \
+ "__builtins__", "__debug_code__", "__debug_script__"]
+ for frame in stack_data:
+ for k, v in frame[1]["locals"].items():
+ if k in excluded_names: continue
+ if not v.startswith("<module") and not v.startswith("exec(compile"):
+ locals_dict[k] = v
+ self.viewstack(locals_dict)
+
+ def lookupmodule(self, filename):
+
+ if os.path.isabs(filename) and os.path.exists(filename):
+ return filename
+ f = os.path.join(sys.path[0], filename)
+ if os.path.exists(f) and self.canonic(f) == self.mainpyfile:
+ return f
+ root, ext = os.path.splitext(filename)
+ if ext == '':
+ filename = filename + '.py'
+ if os.path.isabs(filename):
+ return filename
+ for dirname in sys.path:
+ while os.path.islink(dirname):
+ dirname = os.readlink(dirname)
+ fullname = os.path.join(dirname, filename)
+ if os.path.exists(fullname):
+ return fullname
+ return None
+
+ def _runscript(self, filename):
+ # The script has to run in __main__ namespace (or imports from
+ # __main__ will break).
+ #
+ # So we clear up the __main__ and set several special variables
+ # (this gets rid of pdb's globals and cleans old variables on restarts).
+ import __main__
+ __main__.__dict__.clear()
+ __main__.__dict__.update({"__name__" : "__main__",
+ "__file__" : filename,
+ "__builtins__": __builtins__,
+ })
+
+ # When bdb sets tracing, a number of call and line events happens
+ # BEFORE debugger even reaches user's code (and the exact sequence of
+ # events depends on python version). So we take special measures to
+ # avoid stopping before we reach the main script (see user_line and
+ # user_call for details).
+ self._wait_for_mainpyfile = True
+ self.mainpyfile = self.canonic(filename)
+ self._user_requested_quit = False
+
+ with open(filename, "rb") as fp:
+ statement = "exec(compile(%r, %r, 'exec'))" % \
+ (fp.read(), self.mainpyfile)
+ self.run(statement)
+
+# Simplified interface
+
+def run(statement, globals=None, locals=None):
+ Pdb().run(statement, globals, locals)
+
+def runeval(expression, globals=None, locals=None):
+ return Pdb().runeval(expression, globals, locals)
+
+def runctx(statement, globals, locals):
+ # B/W compatibility
+ run(statement, globals, locals)
+
+def runcall(*args, **kwds):
+ return Pdb().runcall(*args, **kwds)
+
+def set_trace():
+ Pdb().set_trace(sys._getframe().f_back)
+
+# Post-Mortem interface
+def post_mortem(t=None):
+ # handling the default
+ if t is None:
+ # sys.exc_info() returns (type, value, traceback) if an exception is
+ # being handled, otherwise it returns None
+ t = sys.exc_info()[2]
+ if t is None:
+ raise ValueError("A valid traceback must be passed if no "
+ "exception is being handled")
+
+ p = Pdb()
+ p.reset()
+ p.interaction(None, t)
+
+def pm():
+ post_mortem(sys.last_traceback)
+
--- /dev/null
+#! /usr/bin/env python
+
+# A generic Python debugger for Speare Pro.
+# Copyright (c) 2019 sevenuc.com. All rights reserved.
+#
+# THIS FILE IS PART OF THE ADVANCED VERSION OF SPEARE CODE EDITOR.
+# WITHOUT THE WRITTEN PERMISSION OF THE AUTHOR THIS FILE MAY NOT
+# BE USED FOR ANY COMMERCIAL PRODUCT.
+#
+# More info:
+# http://sevenuc.com/en/Speare.html
+# Contact:
+# Sevenuc support <info@sevenuc.com>
+# Issue report and requests pull:
+# https://github.com/chengdu/Speare
+
+from __future__ import print_function
+import errno
+import os
+import re
+import socket
+import sys
+from debugger import Debugger
+
+__version__ = '0.0.2'
+def info(message, stderr=sys.__stderr__):
+ print(message, file=stderr)
+ stderr.flush()
+
+class SocketHandle(object):
+ def __init__(self, connection):
+ self.connection = connection
+ self.stream = fh = connection.makefile('rw')
+ self.read = fh.read
+ self.readline = fh.readline
+ self.readlines = fh.readlines
+ self.close = fh.close
+ self.flush = fh.flush
+ self.fileno = fh.fileno
+ if hasattr(fh, 'encoding'):
+ self._send = lambda data: connection.sendall(data.encode(fh.encoding))
+ else:
+ self._send = connection.sendall
+
+ @property
+ def encoding(self):
+ return self.stream.encoding
+
+ def __iter__(self):
+ return self.stream.__iter__()
+
+ def write(self, data, nl_rex=re.compile("\r?\n")):
+ data = nl_rex.sub("\r\n", data)
+ self._send(data)
+
+ def writelines(self, lines, nl_rex=re.compile("\r?\n")):
+ for line in lines:
+ self.write(line, nl_rex)
+ self.stream.flush()
+
+class Debugstub(Debugger):
+ active_instance = None
+
+ def __init__(self, sock, connection):
+ self._quiet = False
+ patch_stdstreams=False
+ self.sock = sock
+ self.connection = connection
+ self.handle = SocketHandle(connection)
+ Debugger.__init__(self, completekey='tab', stdin=self.handle, stdout=self.handle)
+ self.backup = []
+ if patch_stdstreams:
+ for name in (
+ 'stderr',
+ 'stdout',
+ '__stderr__',
+ '__stdout__',
+ 'stdin',
+ '__stdin__',
+ ):
+ self.backup.append((name, getattr(sys, name)))
+ setattr(sys, name, self.handle)
+ Debugstub.active_instance = self
+
+ def message(self, msg):
+ print(msg, file=self.stdout)
+ print('\r\n', file=self.stdout)
+
+ def release_sock(self):
+ info('*** socket released.')
+ if self.connection: self.connection.close()
+ if self.sock: self.sock.close()
+
+ def onexception(self):
+ self.release_sock()
+
+ def __restore(self):
+ if self.backup and not self._quiet:
+ info('*** Restoring streams: %s ...' % self.backup)
+ for name, fh in self.backup:
+ setattr(sys, name, fh)
+ self.release_sock()
+ self.handle.close()
+ Debugstub.active_instance = None
+
+ def do_quit(self, arg):
+ self.__restore()
+ return Debugger.do_quit(self, arg)
+
+ do_q = do_exit = do_quit
+
+ def set_trace(self, frame=None):
+ if frame is None:
+ frame = sys._getframe().f_back
+ try:
+ Debugger.set_trace(self, frame)
+ except IOError as exc:
+ if exc.errno != errno.ECONNRESET:
+ raise
+
--- /dev/null
+#! /usr/bin/env python
+
+# A generic Python debugger for Speare Pro.
+# Copyright (c) 2019 sevenuc.com. All rights reserved.
+#
+# THIS FILE IS PART OF THE ADVANCED VERSION OF SPEARE CODE EDITOR.
+# WITHOUT THE WRITTEN PERMISSION OF THE AUTHOR THIS FILE MAY NOT
+# BE USED FOR ANY COMMERCIAL PRODUCT.
+#
+# More info:
+# http://sevenuc.com/en/Speare.html
+# Contact:
+# Sevenuc support <info@sevenuc.com>
+# Issue report and requests pull:
+# https://github.com/chengdu/Speare
+
+import os
+import sys
+import codecs
+import signal
+import socket
+from bdb import BdbQuit
+from debugstub import Debugstub
+
+port = 4444
+__version__ = '0.0.2'
+if (sys.version_info.major != 3):
+ print("Wrong Python version!")
+ sys.exit(0)
+
+def printbanner():
+ print("\n")
+ print(" ____")
+ print(" / __/ __ ___ ___ ___ ___")
+ print(" _\\ \\/ _ \\/ -_) _ `/ __/ -_)")
+ print(" /___/ .__/\\__/\\_,_/_/ \\__/")
+ print(" /_/")
+ print("Speare Debug Server v1.0")
+ print("(c) http://sevenuc.com \n")
+
+def startDebugger(sock, connection, port, filename):
+ print('Start debugging session on: %s' % filename)
+ base = os.path.dirname(filename)
+ sys.path.insert(0, base)
+ signal.signal(signal.SIGTTOU, signal.SIG_IGN)
+ dbs = Debugstub(sock, connection)
+ dir_path = os.path.dirname(os.path.realpath(__file__))
+ files = ["debugger.py", "debugstub.py", "server.py"]
+ dbs.excluded_files = map(lambda x: os.path.join(dir_path, x), files)
+ dbs.set_trace()
+ dbs.basedirs = []
+ dbs.basedirs.append(base)
+ dbs._runscript(filename)
+
+if len(sys.argv) == 2:
+ try: port = int(sys.argv[1])
+ except:
+ print('*** invalid port number: "%s".' % sys.argv[1])
+ sys.exit(0)
+
+filename = None
+sock = socket.socket(socket.AF_INET, socket.SOCK_STREAM)
+server_address = ('localhost', port)
+sock.bind(server_address) # Address already in use
+sock.listen(1) # Listen for incoming connection
+printbanner()
+print('Listen on port %d ...' % port)
+connection, client_address = sock.accept()
+#connection.setsockopt(socket.IPPROTO_TCP, socket.TCP_NODELAY, 1)
+while True:
+ data = connection.recv(1024) # Receive the startup script
+ filename = data.decode('utf-8').strip('\r\n')
+ if filename.startswith("b'"): filename = filename[2:-2]
+ break
+try:
+ if filename: startDebugger(sock, connection, port, filename)
+ else: print("*** can't get a script to start debugging session.")
+finally:
+ if connection: connection.close()
+ if sock: sock.close()
+
--- /dev/null
+#!/bin/sh
+#kill process when address already in use
+port=4444
+if [ $# -eq 1 ]
+ then port=$1
+fi
+lsof -iTCP -sTCP:LISTEN -n -P | grep $port | awk '{print $2}'| xargs kill -9
+
--- /dev/null
+Speare Debug Server v1.0
+Copyright (c) 2019 sevenuc.com. All rights reserved.
+
+This is the Python debugger for Speare Pro:
+http://sevenuc.com/en/Speare.html
+
+Package source and download:
+https://github.com/chengdu/Speare
+http://sevenuc.com/download/python_debugger.tar.gz
+
+Directory Structure:
+
+debugger
+|____2.x # Python debugger for 2.5, 2.6, 2.7
+| |____debugger.py
+| |____debugstub.py
+| |____server.py
+|____3.x # Python debugger for 3.x
+| |____debugger.py
+| |____debugstub.py
+| |____server.py
+|____killproc.sh # shell script to kill Python process
+|____readme.txt # readme for this package
+
+
+Start Debug Server:
+1. For Python 2.5, 2.6, 2.7
+$ cd ~/Desktop/debugger/2.x
+$ python server.py
+
+2. For Python 3.x
+$ cd ~/Desktop/debugger/3.x
+$ python3 server.py
+
+You can directly switch to any Python interpreter to start a
+debugging session or use your own customised Python version.
+
+12 Oct 2019
+
+
+
+
+
--- /dev/null
+#!/usr/bin/perl -w
+
+# A MATLAB helper script for Speare code editor.
+# Copyright (c) 2019 sevenuc.com. All rights reserved.
+#
+# THIS FILE IS PART OF SPEARE CODE EDITOR. WITHOUT THE
+# WRITTEN PERMISSION OF THE AUTHOR THIS FILE MAY NOT
+# BE USED FOR ANY COMMERCIAL PRODUCT.
+#
+# More info:
+# http://sevenuc.com/en/Speare.html
+# Contact:
+# Sevenuc support <info@sevenuc.com>
+# Issue report and requests pull:
+# https://github.com/chengdu/Speare
+
+use strict;
+use warnings;
+use Cwd;
+use File::Basename;
+use utf8;
+
+binmode STDIN, ':utf8';
+binmode STDOUT, ':utf8';
+binmode STDERR, ':utf8';
+
+sub scanDirectory{
+ my $workdir = shift @_;
+ chdir($workdir) or die "Unable to enter dir $workdir:$!\n";
+ my ($startdir) = &cwd;
+ opendir(DIR, $workdir) or die "Unable to open $workdir:$!\n"; # "."
+ my @names = readdir(DIR) or die "Unable to read $workdir:$!\n";
+ closedir(DIR);
+
+ foreach my $name (@names){
+ next if ($name eq ".");
+ next if ($name eq "..");
+ my $filepath = $workdir."/".$name;
+ if (-d $filepath) {
+ &scanDirectory($filepath);
+ next;
+ }
+ my ($basename, $parentdir, $extension) = fileparse($filepath, qr/\.[^.]*$/);
+ #if ($name =~ /\.m$/) {
+ if ($extension eq ".m") {
+ print($filepath, "\n");
+ my $newpath = $workdir."/".$basename.".mat"; # .m --> .mat
+ my $command = "mv \"$filepath\" \"$newpath\"";
+ system($command);
+ }
+ chdir($startdir) or
+ die "Unable to change to dir $startdir:$!\n";
+ }
+}
+
+# To prevent conflict with objective-c files,
+# MATLAB source code file extension name must be renamed from .m to .mat.
+if ($#ARGV + 1 == 1) {
+ my $srcdir = $ARGV[0];
+ print("Rename source files in ".$srcdir." ...\n");
+ &scanDirectory($srcdir);
+}else{
+ print("Usage: perl rename.pl directory.\n");
+}
+
+
OSDN Git Service
