├── .gitignore ├── .travis.yml ├── .vscode ├── launch.json ├── settings.json └── tasks.json ├── .vscodeignore ├── CHANGELOG.md ├── LICENSE.txt ├── Makefile ├── ThirdPartyNotices.txt ├── appveyor.yml ├── images ├── mock-debug-icon.png └── mock-debug.gif ├── package-lock.json ├── package.json ├── package.nls.json ├── readme.md └── src ├── debugAdapter.ts ├── extension.ts ├── mockDebug.ts ├── mockRuntime.ts ├── tcl ├── debugger.tcl ├── lib │ ├── projectInfo │ │ ├── pkgIndex.tcl │ │ └── projectInfo.tcl │ └── tcldebugger │ │ ├── appLaunch.tcl │ │ ├── bindings.tcl │ │ ├── blend.pdx │ │ ├── block.tcl │ │ ├── break.tcl │ │ ├── breakWin.tcl │ │ ├── codeWin.tcl │ │ ├── coverage.tcl │ │ ├── dbg.tcl │ │ ├── debugger.tcl │ │ ├── evalWin.tcl │ │ ├── file.tcl │ │ ├── find.tcl │ │ ├── font.tcl │ │ ├── gui.tcl │ │ ├── guiUtil.tcl │ │ ├── icon.tcl │ │ ├── image.tcl │ │ ├── initdebug.tcl │ │ ├── inspectorWin.tcl │ │ ├── instrument.tcl │ │ ├── location.tcl │ │ ├── menu.tcl │ │ ├── nub.tcl │ │ ├── oratcl.pdx │ │ ├── pkgIndex.tcl │ │ ├── portWin.tcl │ │ ├── pref.tcl │ │ ├── prefWin.tcl │ │ ├── procWin.tcl │ │ ├── proj.tcl │ │ ├── projWin.tcl │ │ ├── result.tcl │ │ ├── selection.tcl │ │ ├── stackWin.tcl │ │ ├── sybtcl.pdx │ │ ├── system.tcl │ │ ├── tabnotebook.tcl │ │ ├── tclCom.pdx │ │ ├── tcltest.pdx │ │ ├── tests │ │ ├── all.tcl │ │ ├── block.test │ │ ├── dbgLaunch.tcl │ │ ├── guiLaunch.tcl │ │ ├── initProject.tcl │ │ ├── initdebug.test │ │ ├── instrument.test │ │ ├── pkgIndex.tcl │ │ ├── pref.test │ │ ├── protest.tcl │ │ ├── startup.tcl │ │ └── system.test │ │ ├── tkcon.tcl │ │ ├── toolbar.tcl │ │ ├── uplevel.pdx │ │ ├── util.tcl │ │ ├── varWin.tcl │ │ ├── watchWin.tcl │ │ ├── widget.tcl │ │ └── xmlGen.pdx ├── tclDebug.tcl └── test_debugger.tcl ├── tests ├── adapter.test.ts └── data │ ├── test.md │ ├── testLazyBreakpoint.md │ └── testWithException.md ├── tsconfig.json └── tslint.json /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | node_modules/ 3 | out/ 4 | npm-debug.log 5 | mock-debug.txt 6 | *.vsix 7 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: node_js 2 | node_js: 3 | - "7.9" 4 | sudo: false 5 | -------------------------------------------------------------------------------- /.vscode/launch.json: -------------------------------------------------------------------------------- 1 | { 2 | "version": "0.2.0", 3 | "configurations": [ 4 | { 5 | "type": "extensionHost", 6 | "request": "launch", 7 | "name": "Extension", 8 | "preLaunchTask": "npm", 9 | "runtimeExecutable": "${execPath}", 10 | "args": [ 11 | "--extensionDevelopmentPath=${workspaceFolder}" 12 | ], 13 | "outFiles": [ "${workspaceFolder}/out/**/*.js" ] 14 | }, 15 | { 16 | "type": "node", 17 | "request": "launch", 18 | "name": "Server", 19 | "cwd": "${workspaceFolder}", 20 | "program": "${workspaceFolder}/src/debugAdapter.ts", 21 | "args": [ "--server=4711" ], 22 | "outFiles": [ "${workspaceFolder}/out/**/*.js" ] 23 | }, 24 | { 25 | "type": "node", 26 | "request": "launch", 27 | "name": "Tests", 28 | "cwd": "${workspaceFolder}", 29 | "program": "${workspaceFolder}/node_modules/mocha/bin/_mocha", 30 | "args": [ 31 | "-u", "tdd", 32 | "--timeout", "999999", 33 | "--colors", 34 | "./out/tests/" 35 | ], 36 | "outFiles": [ "${workspaceFolder}/out/**/*.js" ], 37 | "internalConsoleOptions": "openOnSessionStart" 38 | }, 39 | { 40 | "type": "mock", 41 | "request": "launch", 42 | "name": "Mock Sample", 43 | "program": "${workspaceFolder}/${command:AskForProgramName}", 44 | "stopOnEntry": true 45 | } 46 | ], 47 | "compounds": [ 48 | { 49 | "name": "Extension + Server", 50 | "configurations": [ "Extension", "Server" ] 51 | } 52 | ] 53 | } 54 | -------------------------------------------------------------------------------- /.vscode/settings.json: -------------------------------------------------------------------------------- 1 | // Place your settings in this file to overwrite default and user settings.FALSE 2 | { 3 | "javascript.validate.enable": false, 4 | "typescript.tsdk": "node_modules/typescript/lib", 5 | "files.trimTrailingWhitespace": true, 6 | "editor.insertSpaces": false 7 | } -------------------------------------------------------------------------------- /.vscode/tasks.json: -------------------------------------------------------------------------------- 1 | { 2 | "version": "2.0.0", 3 | "tasks": [ 4 | { 5 | "type": "npm", 6 | "identifier": "npm", 7 | "script": "watch", 8 | "problemMatcher": [ 9 | "$tsc-watch" 10 | ], 11 | "isBackground": true, 12 | "group": { 13 | "kind": "build", 14 | "isDefault": true 15 | } 16 | } 17 | ] 18 | } 19 | -------------------------------------------------------------------------------- /.vscodeignore: -------------------------------------------------------------------------------- 1 | .vscode/**/* 2 | .gitignore 3 | .travis.yml 4 | appveyor.yml 5 | src/**/* 6 | out/tests/**/* 7 | **/*.js.map 8 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## 0.26.0 2 | * Improved the launch configuration snippet and added a `"stopOnEntry": true`. 3 | 4 | ## 0.25.0 5 | * Added the `"multi-root ready"` keyword. 6 | 7 | ## 0.24.0 8 | * Add support for starting a debug session without a launch configuration. 9 | * Require 1.17 version of VS Code. 10 | 11 | ## 0.23.0 12 | * Added supported for creating and deleting breakpoints from the REPL. Use `new 123` to create a breakpoint in line 123, and `del 123` to delete it. 13 | * Use 1.24.0 version of Debug Adapter Protocol and libraries. 14 | 15 | ## 0.22.0 16 | * Refactored the 'Mock Debugger' functionality into a separate class. This makes it more obvious how a debug adapter 'adapts' to a debugger or runtime. 17 | 18 | ## 0.21.0 19 | * Shows the source location of log output. A `log(any text)` in the input sends the text in parenthesis to the debug console. 20 | 21 | ## 0.20.0 22 | * Use 1.23.0 version of Debug Adapter Protocol and libraries. 23 | 24 | ## 0.19.0 25 | * Add tslint 26 | * Use 1.19.0 version of Debug Adapter Protocol and libraries. 27 | 28 | ## 0.18.2 29 | * Added 'trace' attribute to launch configuration: set it to 'true' to enable logging of the Debug Adapter Protocol. 30 | 31 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | Copyright (c) Microsoft Corporation 2 | 3 | All rights reserved. 4 | 5 | MIT License 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the "Software"), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in all 15 | copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | SOFTWARE. 24 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | cp src/tcl/tclDebug.tcl out/tcl/tclDebug.tcl -------------------------------------------------------------------------------- /ThirdPartyNotices.txt: -------------------------------------------------------------------------------- 1 | THIRD-PARTY SOFTWARE NOTICES AND INFORMATION 2 | Do Not Translate or Localize 3 | 4 | This project incorporates material from the project(s) listed below (collectively, “Third Party Code”). 5 | Microsoft is not the original author of the Third Party Code. The original copyright notice and license 6 | under which Microsoft received such Third Party Code are set out below. This Third Party Code is licensed 7 | to you under their original license terms set forth below. Microsoft reserves all other rights not 8 | expressly granted, whether by implication, estoppel or otherwise. 9 | 10 | 11 | 1. DefinitelyTyped version 0.0.1 (https://github.com/borisyankov/DefinitelyTyped) 12 | 13 | 14 | %% DefinitelyTyped NOTICES AND INFORMATION BEGIN HERE 15 | ========================================= 16 | This project is licensed under the MIT license. 17 | Copyrights are respective of each contributor listed at the beginning of each definition file. 18 | 19 | Permission is hereby granted, free of charge, to any person obtaining a copy 20 | of this software and associated documentation files (the "Software"), to deal 21 | in the Software without restriction, including without limitation the rights 22 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 23 | copies of the Software, and to permit persons to whom the Software is 24 | furnished to do so, subject to the following conditions: 25 | 26 | The above copyright notice and this permission notice shall be included in 27 | all copies or substantial portions of the Software. 28 | 29 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 30 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 31 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 32 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 33 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 34 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 35 | THE SOFTWARE. 36 | ========================================= 37 | END OF DefinitelyTyped NOTICES AND INFORMATION 38 | -------------------------------------------------------------------------------- /appveyor.yml: -------------------------------------------------------------------------------- 1 | install: 2 | - ps: Install-Product node 7.9 x64 3 | 4 | build_script: 5 | - npm install 6 | 7 | test_script: 8 | - npm test 9 | -------------------------------------------------------------------------------- /images/mock-debug-icon.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/conej730/vscode-tcl-debug/0fb71a7516208234296b9220e3f4e406f25448bd/images/mock-debug-icon.png -------------------------------------------------------------------------------- /images/mock-debug.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/conej730/vscode-tcl-debug/0fb71a7516208234296b9220e3f4e406f25448bd/images/mock-debug.gif -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "tcl-debug", 3 | "displayName": "Tcl Debug", 4 | "version": "0.27.0", 5 | "publisher": "flightaware", 6 | "description": "Debugging (local, remote) for Tcl", 7 | "author": { 8 | "name": "Jonathan Cone", 9 | "email": "jonathan.cone@flightaware.com" 10 | }, 11 | "license": "MIT", 12 | "keywords": [ 13 | "Debuggers" 14 | ], 15 | "engines": { 16 | "vscode": "^1.18.0", 17 | "node": "^7.9.0" 18 | }, 19 | "icon": "images/mock-debug-icon.png", 20 | "categories": [ 21 | "Debuggers" 22 | ], 23 | "private": true, 24 | "repository": { 25 | "type": "git", 26 | "url": "https://github.com/Microsoft/vscode-mock-debug.git" 27 | }, 28 | "bugs": { 29 | "url": "https://github.com/Microsoft/vscode-mock-debug/issues" 30 | }, 31 | "scripts": { 32 | "prepublish": "tsc -p ./src", 33 | "compile": "tsc -p ./src && cp -r ./src/tcl/* ./out/tcl/", 34 | "tslint": "tslint ./src/**/*.ts", 35 | "watch": "tsc -w -p ./src", 36 | "test": "mocha -u tdd ./out/tests/", 37 | "postinstall": "node ./node_modules/vscode/bin/install", 38 | "package": "vsce package", 39 | "publish": "vsce publish" 40 | }, 41 | "dependencies": { 42 | "await-notify": "1.0.1", 43 | "vscode-debugadapter": "1.27.0", 44 | "vscode-debugprotocol": "1.27.0", 45 | "vscode-nls": "^3.2.4" 46 | }, 47 | "devDependencies": { 48 | "@types/node": "7.0.55", 49 | "@types/mocha": "2.2.48", 50 | "typescript": "2.6.2", 51 | "mocha": "5.0.1", 52 | "vscode": "1.1.17", 53 | "vscode-debugadapter-testsupport": "1.27.0", 54 | "tslint": "5.9.1", 55 | "vsce": "1.37.5" 56 | }, 57 | "main": "./out/extension", 58 | "activationEvents": [ 59 | "onDebug" 60 | ], 61 | "contributes": { 62 | "breakpoints": [ 63 | { 64 | "language": "tcl" 65 | } 66 | ], 67 | "debuggers": [ 68 | { 69 | "type": "tcl", 70 | "label": "Tcl Debug", 71 | "languages": [ 72 | "tcl" 73 | ], 74 | "program": "./out/tcl/tclDebug.tcl", 75 | "runtime": "tclsh", 76 | "initialConfigurations": [ 77 | { 78 | "type": "tcl", 79 | "request": "launch", 80 | "name": "%tcl.launch.config.name%", 81 | "program": "${file}", 82 | "stopOnEntry": false, 83 | "console": "integratedTerminal", 84 | "args": [] 85 | }, 86 | { 87 | "name": "%tcl.attach.config.name%", 88 | "type": "tcl", 89 | "request": "attach", 90 | "port": 5678, 91 | "host": "localhost", 92 | "args": [] 93 | } 94 | ], 95 | "configurationAttributes": { 96 | "launch": { 97 | "properties": { 98 | "program": { 99 | "type": "string", 100 | "description": "Absolute path to the program..", 101 | "default": "${file}" 102 | }, 103 | "tclPath": { 104 | "type": "string", 105 | "description": "Path (fully qualified) to tcl executable. Defaults to the value in settings.json", 106 | "default": "${config:tcl.tclPath}" 107 | }, 108 | "args": { 109 | "type": "array", 110 | "description": "Command line arguments passed to the program", 111 | "default": [], 112 | "items": { 113 | "type": "string" 114 | } 115 | }, 116 | "stopOnEntry": { 117 | "type": "boolean", 118 | "description": "Automatically stop after launch.", 119 | "default": true 120 | }, 121 | "console": { 122 | "enum": [ 123 | "none", 124 | "integratedTerminal", 125 | "externalTerminal" 126 | ], 127 | "description": "Where to launch the debug target: internal console, integrated terminal, or external terminal.", 128 | "default": "integratedTerminal" 129 | }, 130 | "trace": { 131 | "type": "boolean", 132 | "description": "Enable logging of the Debug Adapter Protocol.", 133 | "default": true 134 | }, 135 | "cwd": { 136 | "type": "string", 137 | "description": "Absolute path to the working directory of the program being debugged. Default is the root directory of the file (leave empty).", 138 | "default": "${workspaceFolder}" 139 | }, 140 | "env": { 141 | "type": "object", 142 | "description": "Environment variables defined as a key value pair. Property ends up being the Environment Variable and the value of the property ends up being the value of the Env Variable.", 143 | "default": {} 144 | }, 145 | "envFile": { 146 | "type": "string", 147 | "description": "Absolute path to a file containing environment variable definitions.", 148 | "default": "${workspaceFolder}/.env" 149 | }, 150 | "port": { 151 | "type": "number", 152 | "description": "Debug port (default is 0, resulting in the use of a dynamic port).", 153 | "default": 0 154 | }, 155 | "host": { 156 | "type": "string", 157 | "description": "IP address of the of the local debug server (default is localhost).", 158 | "default": "localhost" 159 | } 160 | } 161 | }, 162 | "attach": { 163 | "required": [ 164 | "port" 165 | ], 166 | "properties": { 167 | "port": { 168 | "type": "number", 169 | "description": "Debug port to attach", 170 | "default": 0 171 | }, 172 | "host": { 173 | "type": "string", 174 | "description": "IP Address of the of remote server (default is localhost or use 127.0.0.1).", 175 | "default": "localhost" 176 | }, 177 | "pathMappings": { 178 | "type": "array", 179 | "label": "Path mappings.", 180 | "items": { 181 | "type": "object", 182 | "label": "Path mapping", 183 | "required": [ 184 | "localRoot", 185 | "remoteRoot" 186 | ], 187 | "properties": { 188 | "localRoot": { 189 | "type": "string", 190 | "label": "Local source root.", 191 | "default": "${workspaceFolder}" 192 | }, 193 | "remoteRoot": { 194 | "type": "string", 195 | "label": "Remote source root.", 196 | "default": "" 197 | } 198 | } 199 | }, 200 | "default": [] 201 | } 202 | } 203 | } 204 | }, 205 | "configurationSnippets": [ 206 | { 207 | "label": "Tcl: Terminal (integrated)", 208 | "description": "%tcl.launch.terminal.description%", 209 | "body": { 210 | "name": "Tcl: Terminal (integrated)", 211 | "type": "tcl", 212 | "request": "launch", 213 | "program": "^\"\\${file}\"", 214 | "console": "integratedTerminal", 215 | "stopOnEntry": false 216 | } 217 | }, 218 | { 219 | "label": "Tcl: Terminal (external)", 220 | "description": "%tcl.launch.externalTerminal.description%", 221 | "body": { 222 | "name": "Tcl: Terminal (external)", 223 | "type": "tcl", 224 | "request": "launch", 225 | "program": "^\"\\${file}\"", 226 | "console": "externalTerminal" 227 | } 228 | }, 229 | { 230 | "label": "Tcl: Attach", 231 | "description": "%tcl.launch.attach.description%", 232 | "body": { 233 | "name": "Attach (Remote Debug)", 234 | "type": "tcl", 235 | "request": "attach", 236 | "port": 5678, 237 | "host": "localhost" 238 | } 239 | } 240 | ] 241 | } 242 | ], 243 | "configuration": { 244 | "type": "object", 245 | "title": "Tcl Configuration", 246 | "properties": { 247 | "tcl.tclshPath": { 248 | "type": "string", 249 | "default": "tclsh", 250 | "description": "Path to Tcl, you can use a custom version of Tcl by modifying this setting to include the full path.", 251 | "scope": "resource" 252 | } 253 | } 254 | } 255 | } 256 | } 257 | -------------------------------------------------------------------------------- /package.nls.json: -------------------------------------------------------------------------------- 1 | { 2 | "tcl.label": "Tcl", 3 | 4 | "tcl.launch.config.name": "Tcl: Current File", 5 | "tcl.attach.config.name": "Tcl: Attach", 6 | 7 | "tcl.launch.program.description": "Absolute path to the program.", 8 | "tcl.launch.args.description": "Command line arguments passed to the program.", 9 | "tcl.launch.cwd.description": "Absolute path to the working directory of the program being debugged.", 10 | "tcl.launch.runtimeExecutable.description": "Absolute path to the runtime executable to be used. Default is the runtime executable on the PATH.", 11 | "tcl.launch.runtimeArgs.description": "Optional arguments passed to the runtime executable.", 12 | "tcl.launch.env.description": "Environment variables passed to the program.", 13 | "tcl.launch.console.description": "Where to launch the debug target.", 14 | "tcl.launch.console.internalConsole.description": "VS Code Debug Console (which doesn't support to read input from a program)", 15 | "tcl.launch.console.integratedTerminal.description": "VS Code's integrated terminal", 16 | "tcl.launch.console.externalTerminal.description": "external terminal that can be configured via user settings", 17 | "tcl.launch.terminal.description": "Debug a TCL program with Integrated Terminal/Console", 18 | "tcl.launch.externalTerminal.description": "Debug a TCL program with an external Terminal/Console", 19 | "tcl.launch.attach.description": "Attached", 20 | 21 | "tcl.attach.port.description": "Debug port to attach to.", 22 | "tcl.attach.address.description": "TCP/IP address. Default is \"localhost\"." 23 | } -------------------------------------------------------------------------------- /readme.md: -------------------------------------------------------------------------------- 1 | # VS Code Tcl Debug 2 | 3 | This is an extension for debugging Tcl code. 4 | 5 | **Tcl Debug** implements a debug adapter for Visual Studio Code. 6 | It supports *step*, *continue*, *breakpoints*, *exceptions*, and 7 | *variable access* but it is not connected to any real debugger. 8 | 9 | The sample is meant as an educational piece showing how to implement a debug 10 | adapter for VS Code. It can be used as a starting point for developing a real adapter. 11 | 12 | More information about how to develop a new debug adapter can be found 13 | [here](https://code.visualstudio.com/docs/extensions/example-debuggers). 14 | Or discuss debug adapters on Gitter: 15 | [![Gitter Chat](https://img.shields.io/badge/chat-online-brightgreen.svg)](https://gitter.im/Microsoft/vscode) 16 | 17 | ## Using Tcl Debug 18 | 19 | * Install the **Mock Debug** extension in VS Code. 20 | * Create a new 'program' file `readme.md` and enter several lines of arbitrary text. 21 | * Switch to the debug viewlet and press the gear dropdown. 22 | * Select the debug environment "Mock Debug". 23 | * Press the green 'play' button to start debugging. 24 | 25 | You can now 'step through' the `readme.md` file, set and hit breakpoints, and run into exceptions (if the word exception appears in a line). 26 | 27 | ![Mock Debug](images/mock-debug.gif) 28 | 29 | ## Build and Run 30 | 31 | [![build status](https://travis-ci.org/Microsoft/vscode-mock-debug.svg?branch=master)](https://travis-ci.org/Microsoft/vscode-mock-debug) 32 | [![build status](https://ci.appveyor.com/api/projects/status/empmw5q1tk6h1fly/branch/master?svg=true)](https://ci.appveyor.com/project/weinand/vscode-mock-debug) 33 | 34 | 35 | * Clone the project [https://github.com/Microsoft/vscode-mock-debug.git](https://github.com/Microsoft/vscode-mock-debug.git) 36 | * Open the project folder in VS Code. 37 | * Press `F5` to build and launch Mock Debug in another VS Code window. In that window: 38 | * Open a new workspace, create a new 'program' file `readme.md` and enter several lines of arbitrary text. 39 | * Switch to the debug viewlet and press the gear dropdown. 40 | * Select the debug environment "Mock Debug". 41 | * Press `F5` to start debugging. 42 | -------------------------------------------------------------------------------- /src/debugAdapter.ts: -------------------------------------------------------------------------------- 1 | /*--------------------------------------------------------- 2 | * Copyright (C) Microsoft Corporation. All rights reserved. 3 | *--------------------------------------------------------*/ 4 | 5 | import { MockDebugSession } from './mockDebug'; 6 | 7 | MockDebugSession.run(MockDebugSession); 8 | -------------------------------------------------------------------------------- /src/extension.ts: -------------------------------------------------------------------------------- 1 | /*--------------------------------------------------------- 2 | * Copyright (C) Microsoft Corporation. All rights reserved. 3 | *--------------------------------------------------------*/ 4 | 5 | 'use strict'; 6 | 7 | import * as vscode from 'vscode'; 8 | import { WorkspaceFolder, DebugConfiguration, ProviderResult, CancellationToken } from 'vscode'; 9 | 10 | export function activate(context: vscode.ExtensionContext) { 11 | 12 | // register a configuration provider for 'tcl' debug type 13 | const provider = new TclConfigurationProvider() 14 | context.subscriptions.push(vscode.debug.registerDebugConfigurationProvider('tcl', provider)); 15 | context.subscriptions.push(provider); 16 | } 17 | 18 | export function deactivate() { 19 | // nothing to do 20 | } 21 | 22 | class TclConfigurationProvider implements vscode.DebugConfigurationProvider { 23 | 24 | /** 25 | * Massage a debug configuration just before a debug session is being launched, 26 | * e.g. add all missing attributes to the debug configuration. 27 | */ 28 | resolveDebugConfiguration(folder: WorkspaceFolder | undefined, config: DebugConfiguration, token?: CancellationToken): ProviderResult { 29 | 30 | // if launch.json is missing or empty 31 | if (!config.type && !config.request && !config.name) { 32 | const editor = vscode.window.activeTextEditor; 33 | if (editor && editor.document.languageId === 'tcl' ) { 34 | config.type = 'tcl'; 35 | config.name = 'Launch'; 36 | config.request = 'launch'; 37 | config.program = '${file}'; 38 | config.stopOnEntry = true; 39 | } 40 | } 41 | 42 | if (!config.program) { 43 | return vscode.window.showInformationMessage("Cannot find a program to debug").then(_ => { 44 | return undefined; // abort launch 45 | }); 46 | } 47 | 48 | return config; 49 | } 50 | 51 | dispose() { 52 | 53 | } 54 | } 55 | -------------------------------------------------------------------------------- /src/mockDebug.ts: -------------------------------------------------------------------------------- 1 | /*--------------------------------------------------------- 2 | * Copyright (C) Microsoft Corporation. All rights reserved. 3 | *--------------------------------------------------------*/ 4 | 5 | import { 6 | Logger, logger, 7 | LoggingDebugSession, 8 | InitializedEvent, TerminatedEvent, StoppedEvent, BreakpointEvent, OutputEvent, 9 | Thread, StackFrame, Scope, Source, Handles, Breakpoint 10 | } from 'vscode-debugadapter'; 11 | import { DebugProtocol } from 'vscode-debugprotocol'; 12 | import { basename } from 'path'; 13 | import { MockRuntime, MockBreakpoint } from './mockRuntime'; 14 | const { Subject } = require('await-notify'); 15 | 16 | 17 | /** 18 | * This interface describes the mock-debug specific launch attributes 19 | * (which are not part of the Debug Adapter Protocol). 20 | * The schema for these attributes lives in the package.json of the mock-debug extension. 21 | * The interface should always match this schema. 22 | */ 23 | interface LaunchRequestArguments extends DebugProtocol.LaunchRequestArguments { 24 | /** An absolute path to the "program" to debug. */ 25 | program: string; 26 | /** Automatically stop target after launch. If not specified, target does not stop. */ 27 | stopOnEntry?: boolean; 28 | /** enable logging the Debug Adapter Protocol */ 29 | trace?: boolean; 30 | } 31 | 32 | export class MockDebugSession extends LoggingDebugSession { 33 | 34 | // we don't support multiple threads, so we can use a hardcoded ID for the default thread 35 | private static THREAD_ID = 1; 36 | 37 | // a Mock runtime (or debugger) 38 | private _runtime: MockRuntime; 39 | 40 | private _variableHandles = new Handles(); 41 | 42 | private _configurationDone = new Subject(); 43 | 44 | /** 45 | * Creates a new debug adapter that is used for one debug session. 46 | * We configure the default implementation of a debug adapter here. 47 | */ 48 | public constructor() { 49 | super("mock-debug.txt"); 50 | 51 | // this debugger uses zero-based lines and columns 52 | this.setDebuggerLinesStartAt1(false); 53 | this.setDebuggerColumnsStartAt1(false); 54 | 55 | this._runtime = new MockRuntime(); 56 | 57 | // setup event handlers 58 | this._runtime.on('stopOnEntry', () => { 59 | this.sendEvent(new StoppedEvent('entry', MockDebugSession.THREAD_ID)); 60 | }); 61 | this._runtime.on('stopOnStep', () => { 62 | this.sendEvent(new StoppedEvent('step', MockDebugSession.THREAD_ID)); 63 | }); 64 | this._runtime.on('stopOnBreakpoint', () => { 65 | this.sendEvent(new StoppedEvent('breakpoint', MockDebugSession.THREAD_ID)); 66 | }); 67 | this._runtime.on('stopOnException', () => { 68 | this.sendEvent(new StoppedEvent('exception', MockDebugSession.THREAD_ID)); 69 | }); 70 | this._runtime.on('breakpointValidated', (bp: MockBreakpoint) => { 71 | this.sendEvent(new BreakpointEvent('changed', { verified: bp.verified, id: bp.id })); 72 | }); 73 | this._runtime.on('output', (text, filePath, line, column) => { 74 | const e: DebugProtocol.OutputEvent = new OutputEvent(`${text}\n`); 75 | e.body.source = this.createSource(filePath); 76 | e.body.line = this.convertDebuggerLineToClient(line); 77 | e.body.column = this.convertDebuggerColumnToClient(column); 78 | this.sendEvent(e); 79 | }); 80 | this._runtime.on('end', () => { 81 | this.sendEvent(new TerminatedEvent()); 82 | }); 83 | } 84 | 85 | /** 86 | * The 'initialize' request is the first request called by the frontend 87 | * to interrogate the features the debug adapter provides. 88 | */ 89 | protected initializeRequest(response: DebugProtocol.InitializeResponse, args: DebugProtocol.InitializeRequestArguments): void { 90 | 91 | // build and return the capabilities of this debug adapter: 92 | response.body = response.body || {}; 93 | 94 | // the adapter implements the configurationDoneRequest. 95 | response.body.supportsConfigurationDoneRequest = true; 96 | 97 | // make VS Code to use 'evaluate' when hovering over source 98 | response.body.supportsEvaluateForHovers = true; 99 | 100 | // make VS Code to show a 'step back' button 101 | response.body.supportsStepBack = true; 102 | 103 | this.sendResponse(response); 104 | 105 | // since this debug adapter can accept configuration requests like 'setBreakpoint' at any time, 106 | // we request them early by sending an 'initializeRequest' to the frontend. 107 | // The frontend will end the configuration sequence by calling 'configurationDone' request. 108 | this.sendEvent(new InitializedEvent()); 109 | } 110 | 111 | /** 112 | * Called at the end of the configuration sequence. 113 | * Indicates that all breakpoints etc. have been sent to the DA and that the 'launch' can start. 114 | */ 115 | protected configurationDoneRequest(response: DebugProtocol.ConfigurationDoneResponse, args: DebugProtocol.ConfigurationDoneArguments): void { 116 | super.configurationDoneRequest(response, args); 117 | 118 | // notify the launchRequest that configuration has finished 119 | this._configurationDone.notify(); 120 | } 121 | 122 | protected async launchRequest(response: DebugProtocol.LaunchResponse, args: LaunchRequestArguments) { 123 | 124 | // make sure to 'Stop' the buffered logging if 'trace' is not set 125 | logger.setup(args.trace ? Logger.LogLevel.Verbose : Logger.LogLevel.Stop, false); 126 | 127 | // wait until configuration has finished (and configurationDoneRequest has been called) 128 | await this._configurationDone.wait(1000); 129 | 130 | // start the program in the runtime 131 | this._runtime.start(args.program, !!args.stopOnEntry); 132 | 133 | this.sendResponse(response); 134 | } 135 | 136 | protected setBreakPointsRequest(response: DebugProtocol.SetBreakpointsResponse, args: DebugProtocol.SetBreakpointsArguments): void { 137 | 138 | const path = args.source.path; 139 | const clientLines = args.lines || []; 140 | 141 | // clear all breakpoints for this file 142 | this._runtime.clearBreakpoints(path); 143 | 144 | // set and verify breakpoint locations 145 | const actualBreakpoints = clientLines.map(l => { 146 | let { verified, line, id } = this._runtime.setBreakPoint(path, this.convertClientLineToDebugger(l)); 147 | const bp = new Breakpoint(verified, this.convertDebuggerLineToClient(line)); 148 | bp.id= id; 149 | return bp; 150 | }); 151 | 152 | // send back the actual breakpoint positions 153 | response.body = { 154 | breakpoints: actualBreakpoints 155 | }; 156 | this.sendResponse(response); 157 | } 158 | 159 | protected threadsRequest(response: DebugProtocol.ThreadsResponse): void { 160 | 161 | // runtime supports now threads so just return a default thread. 162 | response.body = { 163 | threads: [ 164 | new Thread(MockDebugSession.THREAD_ID, "thread 1") 165 | ] 166 | }; 167 | this.sendResponse(response); 168 | } 169 | 170 | protected stackTraceRequest(response: DebugProtocol.StackTraceResponse, args: DebugProtocol.StackTraceArguments): void { 171 | 172 | const startFrame = typeof args.startFrame === 'number' ? args.startFrame : 0; 173 | const maxLevels = typeof args.levels === 'number' ? args.levels : 1000; 174 | const endFrame = startFrame + maxLevels; 175 | 176 | const stk = this._runtime.stack(startFrame, endFrame); 177 | 178 | response.body = { 179 | stackFrames: stk.frames.map(f => new StackFrame(f.index, f.name, this.createSource(f.file), this.convertDebuggerLineToClient(f.line))), 180 | totalFrames: stk.count 181 | }; 182 | this.sendResponse(response); 183 | } 184 | 185 | protected scopesRequest(response: DebugProtocol.ScopesResponse, args: DebugProtocol.ScopesArguments): void { 186 | 187 | const frameReference = args.frameId; 188 | const scopes = new Array(); 189 | scopes.push(new Scope("Local", this._variableHandles.create("local_" + frameReference), false)); 190 | scopes.push(new Scope("Global", this._variableHandles.create("global_" + frameReference), true)); 191 | 192 | response.body = { 193 | scopes: scopes 194 | }; 195 | this.sendResponse(response); 196 | } 197 | 198 | protected variablesRequest(response: DebugProtocol.VariablesResponse, args: DebugProtocol.VariablesArguments): void { 199 | 200 | const variables = new Array(); 201 | const id = this._variableHandles.get(args.variablesReference); 202 | if (id !== null) { 203 | variables.push({ 204 | name: id + "_i", 205 | type: "integer", 206 | value: "123", 207 | variablesReference: 0 208 | }); 209 | variables.push({ 210 | name: id + "_f", 211 | type: "float", 212 | value: "3.14", 213 | variablesReference: 0 214 | }); 215 | variables.push({ 216 | name: id + "_s", 217 | type: "string", 218 | value: "hello world", 219 | variablesReference: 0 220 | }); 221 | variables.push({ 222 | name: id + "_o", 223 | type: "object", 224 | value: "Object", 225 | variablesReference: this._variableHandles.create("object_") 226 | }); 227 | } 228 | 229 | response.body = { 230 | variables: variables 231 | }; 232 | this.sendResponse(response); 233 | } 234 | 235 | protected continueRequest(response: DebugProtocol.ContinueResponse, args: DebugProtocol.ContinueArguments): void { 236 | this._runtime.continue(); 237 | this.sendResponse(response); 238 | } 239 | 240 | protected reverseContinueRequest(response: DebugProtocol.ReverseContinueResponse, args: DebugProtocol.ReverseContinueArguments) : void { 241 | this._runtime.continue(true); 242 | this.sendResponse(response); 243 | } 244 | 245 | protected nextRequest(response: DebugProtocol.NextResponse, args: DebugProtocol.NextArguments): void { 246 | this._runtime.step(); 247 | this.sendResponse(response); 248 | } 249 | 250 | protected stepBackRequest(response: DebugProtocol.StepBackResponse, args: DebugProtocol.StepBackArguments): void { 251 | this._runtime.step(true); 252 | this.sendResponse(response); 253 | } 254 | 255 | protected evaluateRequest(response: DebugProtocol.EvaluateResponse, args: DebugProtocol.EvaluateArguments): void { 256 | 257 | let reply: string | undefined = undefined; 258 | 259 | if (args.context === 'repl') { 260 | // 'evaluate' supports to create and delete breakpoints from the 'repl': 261 | const matches = /new +([0-9]+)/.exec(args.expression); 262 | if (matches && matches.length === 2) { 263 | const mbp = this._runtime.setBreakPoint(this._runtime.sourceFile, this.convertClientLineToDebugger(parseInt(matches[1]))); 264 | const bp = new Breakpoint(mbp.verified, this.convertDebuggerLineToClient(mbp.line), undefined, this.createSource(this._runtime.sourceFile)); 265 | bp.id= mbp.id; 266 | this.sendEvent(new BreakpointEvent('new', bp)); 267 | reply = `breakpoint created`; 268 | } else { 269 | const matches = /del +([0-9]+)/.exec(args.expression); 270 | if (matches && matches.length === 2) { 271 | const mbp = this._runtime.clearBreakPoint(this._runtime.sourceFile, this.convertClientLineToDebugger(parseInt(matches[1]))); 272 | if (mbp) { 273 | const bp = new Breakpoint(false); 274 | bp.id= mbp.id; 275 | this.sendEvent(new BreakpointEvent('removed', bp)); 276 | reply = `breakpoint deleted`; 277 | } 278 | } 279 | } 280 | } 281 | 282 | response.body = { 283 | result: reply ? reply : `evaluate(context: '${args.context}', '${args.expression}')`, 284 | variablesReference: 0 285 | }; 286 | this.sendResponse(response); 287 | } 288 | 289 | //---- helpers 290 | 291 | private createSource(filePath: string): Source { 292 | return new Source(basename(filePath), this.convertDebuggerPathToClient(filePath), undefined, undefined, 'mock-adapter-data'); 293 | } 294 | } 295 | -------------------------------------------------------------------------------- /src/mockRuntime.ts: -------------------------------------------------------------------------------- 1 | /*--------------------------------------------------------- 2 | * Copyright (C) Microsoft Corporation. All rights reserved. 3 | *--------------------------------------------------------*/ 4 | 5 | import { readFileSync } from 'fs'; 6 | import { EventEmitter } from 'events'; 7 | 8 | export interface MockBreakpoint { 9 | id: number; 10 | line: number; 11 | verified: boolean; 12 | } 13 | 14 | /** 15 | * A Mock runtime with minimal debugger functionality. 16 | */ 17 | export class MockRuntime extends EventEmitter { 18 | 19 | // the initial (and one and only) file we are 'debugging' 20 | private _sourceFile: string; 21 | public get sourceFile() { 22 | return this._sourceFile; 23 | } 24 | 25 | // the contents (= lines) of the one and only file 26 | private _sourceLines: string[]; 27 | 28 | // This is the next line that will be 'executed' 29 | private _currentLine = 0; 30 | 31 | // maps from sourceFile to array of Mock breakpoints 32 | private _breakPoints = new Map(); 33 | 34 | // since we want to send breakpoint events, we will assign an id to every event 35 | // so that the frontend can match events with breakpoints. 36 | private _breakpointId = 1; 37 | 38 | 39 | constructor() { 40 | super(); 41 | } 42 | 43 | /** 44 | * Start executing the given program. 45 | */ 46 | public start(program: string, stopOnEntry: boolean) { 47 | 48 | this.loadSource(program); 49 | this._currentLine = -1; 50 | 51 | this.verifyBreakpoints(this._sourceFile); 52 | 53 | if (stopOnEntry) { 54 | // we step once 55 | this.step(false, 'stopOnEntry'); 56 | } else { 57 | // we just start to run until we hit a breakpoint or an exception 58 | this.continue(); 59 | } 60 | } 61 | 62 | /** 63 | * Continue execution to the end/beginning. 64 | */ 65 | public continue(reverse = false) { 66 | this.run(reverse, undefined); 67 | } 68 | 69 | /** 70 | * Step to the next/previous non empty line. 71 | */ 72 | public step(reverse = false, event = 'stopOnStep') { 73 | this.run(reverse, event); 74 | } 75 | 76 | /** 77 | * Returns a fake 'stacktrace' where every 'stackframe' is a word from the current line. 78 | */ 79 | public stack(startFrame: number, endFrame: number): any { 80 | 81 | const words = this._sourceLines[this._currentLine].trim().split(/\s+/); 82 | 83 | const frames = new Array(); 84 | // every word of the current line becomes a stack frame. 85 | for (let i = startFrame; i < Math.min(endFrame, words.length); i++) { 86 | const name = words[i]; // use a word of the line as the stackframe name 87 | frames.push({ 88 | index: i, 89 | name: `${name}(${i})`, 90 | file: this._sourceFile, 91 | line: this._currentLine 92 | }); 93 | } 94 | return { 95 | frames: frames, 96 | count: words.length 97 | }; 98 | } 99 | 100 | /* 101 | * Set breakpoint in file with given line. 102 | */ 103 | public setBreakPoint(path: string, line: number) : MockBreakpoint { 104 | 105 | const bp = { verified: false, line, id: this._breakpointId++ }; 106 | let bps = this._breakPoints.get(path); 107 | if (!bps) { 108 | bps = new Array(); 109 | this._breakPoints.set(path, bps); 110 | } 111 | bps.push(bp); 112 | 113 | this.verifyBreakpoints(path); 114 | 115 | return bp; 116 | } 117 | 118 | /* 119 | * Clear breakpoint in file with given line. 120 | */ 121 | public clearBreakPoint(path: string, line: number) : MockBreakpoint | undefined { 122 | let bps = this._breakPoints.get(path); 123 | if (bps) { 124 | const index = bps.findIndex(bp => bp.line === line); 125 | if (index >= 0) { 126 | const bp = bps[index]; 127 | bps.splice(index, 1); 128 | return bp; 129 | } 130 | } 131 | return undefined; 132 | } 133 | 134 | /* 135 | * Clear all breakpoints for file. 136 | */ 137 | public clearBreakpoints(path: string): void { 138 | this._breakPoints.delete(path); 139 | } 140 | 141 | // private methods 142 | 143 | private loadSource(file: string) { 144 | if (this._sourceFile !== file) { 145 | this._sourceFile = file; 146 | this._sourceLines = readFileSync(this._sourceFile).toString().split('\n'); 147 | } 148 | } 149 | 150 | /** 151 | * Run through the file. 152 | * If stepEvent is specified only run a single step and emit the stepEvent. 153 | */ 154 | private run(reverse = false, stepEvent?: string) { 155 | if (reverse) { 156 | for (let ln = this._currentLine-1; ln >= 0; ln--) { 157 | if (this.fireEventsForLine(ln, stepEvent)) { 158 | this._currentLine = ln; 159 | return; 160 | } 161 | } 162 | // no more lines: stop at first line 163 | this._currentLine = 0; 164 | this.sendEvent('stopOnEntry'); 165 | } else { 166 | for (let ln = this._currentLine+1; ln < this._sourceLines.length; ln++) { 167 | if (this.fireEventsForLine(ln, stepEvent)) { 168 | this._currentLine = ln; 169 | return true; 170 | } 171 | } 172 | // no more lines: run to end 173 | this.sendEvent('end'); 174 | } 175 | } 176 | 177 | private verifyBreakpoints(path: string) : void { 178 | let bps = this._breakPoints.get(path); 179 | if (bps) { 180 | this.loadSource(path); 181 | bps.forEach(bp => { 182 | if (!bp.verified && bp.line < this._sourceLines.length) { 183 | const srcLine = this._sourceLines[bp.line].trim(); 184 | 185 | // if a line is empty or starts with '+' we don't allow to set a breakpoint but move the breakpoint down 186 | if (srcLine.length === 0 || srcLine.indexOf('+') === 0) { 187 | bp.line++; 188 | } 189 | // if a line starts with '-' we don't allow to set a breakpoint but move the breakpoint up 190 | if (srcLine.indexOf('-') === 0) { 191 | bp.line--; 192 | } 193 | // don't set 'verified' to true if the line contains the word 'lazy' 194 | // in this case the breakpoint will be verified 'lazy' after hitting it once. 195 | if (srcLine.indexOf('lazy') < 0) { 196 | bp.verified = true; 197 | this.sendEvent('breakpointValidated', bp); 198 | } 199 | } 200 | }); 201 | } 202 | } 203 | 204 | /** 205 | * Fire events if line has a breakpoint or the word 'exception' is found. 206 | * Returns true is execution needs to stop. 207 | */ 208 | private fireEventsForLine(ln: number, stepEvent?: string): boolean { 209 | 210 | const line = this._sourceLines[ln].trim(); 211 | 212 | // if 'log(...)' found in source -> send argument to debug console 213 | const matches = /log\((.*)\)/.exec(line); 214 | if (matches && matches.length === 2) { 215 | this.sendEvent('output', matches[1], this._sourceFile, ln, matches.index) 216 | } 217 | 218 | // if word 'exception' found in source -> throw exception 219 | if (line.indexOf('exception') >= 0) { 220 | this.sendEvent('stopOnException'); 221 | return true; 222 | } 223 | 224 | // is there a breakpoint? 225 | const breakpoints = this._breakPoints.get(this._sourceFile); 226 | if (breakpoints) { 227 | const bps = breakpoints.filter(bp => bp.line === ln); 228 | if (bps.length > 0) { 229 | 230 | // send 'stopped' event 231 | this.sendEvent('stopOnBreakpoint'); 232 | 233 | // the following shows the use of 'breakpoint' events to update properties of a breakpoint in the UI 234 | // if breakpoint is not yet verified, verify it now and send a 'breakpoint' update event 235 | if (!bps[0].verified) { 236 | bps[0].verified = true; 237 | this.sendEvent('breakpointValidated', bps[0]); 238 | } 239 | return true; 240 | } 241 | } 242 | 243 | // non-empty line 244 | if (stepEvent && line.length > 0) { 245 | this.sendEvent(stepEvent); 246 | return true; 247 | } 248 | 249 | // nothing interesting found -> continue 250 | return false; 251 | } 252 | 253 | private sendEvent(event: string, ... args: any[]) { 254 | setImmediate(_ => { 255 | this.emit(event, ...args); 256 | }); 257 | } 258 | } -------------------------------------------------------------------------------- /src/tcl/debugger.tcl: -------------------------------------------------------------------------------- 1 | 2 | namespace eval debugger { 3 | variable interp 4 | variable dir 5 | variable script 6 | variable scriptArgs 7 | variable projName 8 | 9 | variable libdir [file join [file dirname [info script]] lib/tcldebugger] 10 | variable instrumentDynamic 1 11 | variable doInstrument {*} 12 | variable dontInstrument {} 13 | variable autoLoad 0 14 | variable errorAction 1 15 | variable validEvents {attached linebreak} 16 | variable registeredEvent 17 | } 18 | 19 | source [file join $::debugger::libdir dbg.tcl] 20 | source [file join $::debugger::libdir break.tcl] 21 | source [file join $::debugger::libdir block.tcl] 22 | source [file join $::debugger::libdir instrument.tcl] 23 | source [file join $::debugger::libdir coverage.tcl] 24 | source [file join $::debugger::libdir system.tcl] 25 | source [file join $::debugger::libdir location.tcl] 26 | source [file join $::debugger::libdir util.tcl] 27 | 28 | source [file join $::debugger::libdir uplevel.pdx] 29 | source [file join $::debugger::libdir tcltest.pdx] 30 | source [file join $::debugger::libdir oratcl.pdx] 31 | source [file join $::debugger::libdir tclCom.pdx] 32 | source [file join $::debugger::libdir xmlGen.pdx] 33 | 34 | proc debugger::init {} { 35 | variable libdir 36 | variable attachCmd {} 37 | variable afterTime 500 38 | variable afterID 39 | 40 | TestForSockets 41 | 42 | dbg::register linebreak {debugger::linebreakHandler} 43 | dbg::register varbreak {debugger::varbreakHandler} 44 | dbg::register userbreak {debugger::userbreakHandler} 45 | dbg::register cmdresult {debugger::cmdresultHandler} 46 | dbg::register exit {debugger::exitHandler} 47 | dbg::register error {debugger::errorHandler} 48 | dbg::register result {debugger::resultHandler} 49 | dbg::register attach {debugger::attachHandler} 50 | dbg::register instrument {debugger::instrumentHandler} 51 | 52 | 53 | dbg::initialize $libdir 54 | } 55 | 56 | proc debugger::start {cmd} { 57 | variable dir 58 | variable script 59 | variable interp 60 | variable scriptArgs 61 | variable projName 62 | 63 | set script [file join $dir $script] 64 | 65 | if {![dbg::setServerPort random]} { 66 | error "Error setting random port for debugger" 67 | } 68 | 69 | if {[catch {dbg::start $interp $dir $script $scriptArgs $projName} msg] == 1} { 70 | error "Application Initialization Error: $msg" 71 | } else { 72 | if {$cmd == "dbg::run"} { 73 | set cmd "dbg::step run" 74 | } elseif {$cmd == "dbg::step"} { 75 | set cmd "dbg::step any" 76 | } 77 | set debugger::attachCmd $cmd 78 | 79 | return 1 80 | } 81 | 82 | return 0 83 | } 84 | 85 | proc TestForSockets {} { 86 | proc dummy {args} {error dummy} 87 | if {[catch {set socket [socket -server dummy 0]} msg]} { 88 | error "Error: Unable to create socket" 89 | } 90 | close $socket 91 | rename dummy "" 92 | } 93 | 94 | # 95 | # setDebugVars - expects a key/value list of variables for the debug init. Supported 96 | # keys are {interp dir script scriptArgs projName} 97 | # 98 | # @returns 0 on success 99 | # 100 | proc debugger::setDebugVars {debugVars} { 101 | if {[llength $debugVars] % 2 != 0} { 102 | error "setDebugVars should have key/value pairs. Uneven set of elements received. [llength $debugVars] args: $debugVars" 103 | } 104 | 105 | foreach {key value} $debugVars { 106 | if {$key ni {interp dir script scriptArgs projName}} { 107 | error "Invalid key received: $key Must be interp, dir, script, scriptArgs, projName" 108 | } 109 | set ::debugger::$key $value 110 | } 111 | 112 | return 0 113 | } 114 | 115 | proc debugger::run {cmd} { 116 | if {$cmd eq ""} { 117 | set cmd $debugger::attachCmd 118 | } else { 119 | switch $cmd { 120 | run { 121 | set cmd "::dbg::run" 122 | } 123 | over { 124 | set cmd "::dbg::step over" 125 | } 126 | any { 127 | set cmd "::dbg::step any" 128 | } 129 | } 130 | } 131 | 132 | if {$dbg::appState == "dead"} { 133 | debugger::start $cmd 134 | } 135 | 136 | return [eval $cmd] 137 | } 138 | 139 | proc debugger::register {event callback} { 140 | variable registeredEvent 141 | variable validEvents 142 | 143 | if {$event ni $validEvents} { 144 | error "$event is not a valid event" 145 | } 146 | set registeredEvent($event) $callback 147 | return 0 148 | } 149 | 150 | proc debugger::setBreakpoints {_arguments} { 151 | upvar $_arguments arguments 152 | 153 | array set source $arguments(source) 154 | set block $::blk::blockFiles([system::formatFilename $source(path)]) 155 | set body {} 156 | foreach break $arguments(breakpoints) { 157 | lassign $break type pos 158 | if {$type eq "line"} { 159 | set loc [loc::makeLocation $block [lindex $break 1]] 160 | dbg::addLineBreakpoint $loc 161 | lappend body $pos true 162 | } 163 | } 164 | return $body 165 | } 166 | 167 | proc debugger::linebreakHandler {args} { 168 | variable registeredEvent 169 | 170 | set loc [dbg::getPC] 171 | set blk [loc::getBlock $loc] 172 | set line [loc::getLine $loc] 173 | set range [loc::getRange $loc] 174 | set file [blk::getFile $blk] 175 | set ver [blk::getVersion $blk] 176 | 177 | if {[info exists registeredEvent(linebreak)]} { 178 | catch {uplevel #0 $registeredEvent(linebreak) $args} err 179 | } 180 | } 181 | 182 | proc debugger::varbreakHandler {args} { 183 | puts stderr "hit a bar break with args $args" 184 | } 185 | 186 | proc debugger::userbreakHandler {args} { 187 | puts stderr "hit a user break with args $args" 188 | } 189 | 190 | proc debugger::cmdresultHandler {args} { 191 | puts stderr "hit a cmd result with args $args" 192 | } 193 | 194 | proc debugger::exitHandler {args} { 195 | catch {dbg::quit} 196 | send_terminate_event 197 | if {[catch {send_exit_event $args} err] == 1} { 198 | puts stderr "an err? $err" 199 | } 200 | } 201 | 202 | proc debugger::errorHandler {args} { 203 | puts stderr "hit error with args $args" 204 | } 205 | 206 | proc debugger::resultHandler {args} { 207 | puts stderr "hit result with args $args" 208 | } 209 | 210 | proc debugger::attachHandler {projName} { 211 | variable registeredEvent 212 | 213 | if {[info exists registeredEvent(attached)]} { 214 | uplevel #0 $registeredEvent(attached) $projName 215 | } 216 | 217 | set debugger::afterID [after $debugger::afterTime { 218 | debugger::run $debugger::attachCmd 219 | }] 220 | } 221 | 222 | proc debugger::instrumentHandler {status block} { 223 | return 224 | } 225 | 226 | proc debugger::stoppedHandler {breakType} { 227 | if {[info exists debugger::afterID]} { 228 | after cancel $debugger::afterID 229 | } 230 | } 231 | 232 | -------------------------------------------------------------------------------- /src/tcl/lib/projectInfo/pkgIndex.tcl: -------------------------------------------------------------------------------- 1 | package ifneeded projectInfo 2.0 [list source [file join $dir projectInfo.tcl]] 2 | -------------------------------------------------------------------------------- /src/tcl/lib/projectInfo/projectInfo.tcl: -------------------------------------------------------------------------------- 1 | # projectInfo.tcl -- 2 | # 3 | # The "one" location to update version and copyright information 4 | # for the complete xmlserver project. 5 | # 6 | # Copyright (c) 1998-2000 by Ajuba Solutions 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # 9 | # See the file "license.terms" for information on usage and redistribution 10 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. 11 | # 12 | 13 | package provide projectInfo 2.0 14 | namespace eval projectInfo { 15 | # This is the primary product name 16 | 17 | 18 | variable companyName "Tcl Community" 19 | variable corporateName "Tcl Community" 20 | variable companyUrl "http://www.tcl.tk" 21 | variable productName "TclPro" 22 | variable usersGuide "$productName User's Guide" 23 | 24 | # Let's get our bearings! 25 | 26 | variable installationDir [file dirname [file dirname [file norm [info script]]]] 27 | 28 | # This variable can be set to output version information. This 29 | # will be set by the argument processing code in response to the 30 | # -version or -help flags that each product should implement. 31 | 32 | variable printCopyright 0 33 | 34 | # Copyright string - printed by all xmlserver apps. 35 | set year [clock format [clock seconds] -format "%Y"] 36 | variable copyright \ 37 | {This is open source software. 38 | See the file "license.terms" for information 39 | on usage and redistribution of this file. 40 | } 41 | 42 | variable fullCopyright \ 43 | "TBA" 44 | 45 | # These variables hold the parts of a version string. 46 | 47 | variable major 2 48 | variable minor 0 49 | variable type . ;# One of "a", "b", or "." 50 | variable longType release ;# "alpha", "beta", "release" 51 | variable patch 0 ;# One of 0, 1, ... 52 | variable shortVers 20 53 | 54 | variable baseVersion ${major}.${minor} 55 | variable patchLevel ${major}.${minor}${type}${patch} 56 | 57 | # This variable contains the version string that is printed in the 58 | # banner and may be used in otherplaces. 59 | 60 | variable versString $patchLevel 61 | 62 | # The directory name to propose to the user in the installers. 63 | 64 | if {$type == "."} { 65 | variable directoryName ${major}.${minor} 66 | } else { 67 | variable directoryName ${major}.${minor}${type}${patch} 68 | } 69 | 70 | # The current version of Acrobat Reader that we are shipping. 71 | 72 | variable acrobatVersion "3.02" 73 | 74 | # This variable holds the version number for the Scriptics License Server 75 | 76 | variable serverVersion $patchLevel 77 | 78 | variable shortTclVers "83" 79 | variable baseTclVers "8.6" 80 | variable patchTclVers "8.3.2" 81 | 82 | # This array holds the names of the executable files in each bin dir. 83 | 84 | array set executable { 85 | tclsh protclsh83 86 | wish prowish83 87 | tcldebugger prodebug 88 | tclchecker procheck 89 | } 90 | 91 | # This array holds the names of the source directories for each 92 | # source package that is installed with tclpro. 93 | 94 | array set srcDirs { 95 | tcl tcl8.3.2 96 | tk tk8.3.2 97 | itcl itcl3.2 98 | tclx tclx8.3 99 | expect expect5.32 100 | } 101 | 102 | # This array holds the version information for each 103 | # source package that is installed with TclPro. 104 | 105 | array set srcVers { 106 | tcl 8.3.2 107 | tk 8.3.2 108 | itcl 3.2.0 109 | tclx 8.3.0 110 | expect 5.32.2 111 | } 112 | 113 | # This array holds the names of the workspace directories for each 114 | # source package that is used by tclpro. 115 | 116 | array set localSrcDirs { 117 | tcl tcl8.3.2 118 | tk tk8.3.2 119 | itcl itcl3.2 120 | tclx tclx8.3 121 | expect expect5.32 122 | } 123 | 124 | # This variable contains the version string that is printed in the 125 | # banner and may be used in otherplaces. 126 | 127 | variable versString $patchLevel 128 | 129 | # The long version string is only used in the about box for the debugger. 130 | # It can contain a more readable string (such as "beta 2") and build num. 131 | 132 | variable longVersString "${major}.${minor} ${longType} ${patch}" 133 | 134 | # The preference version. This is used to find the location of the 135 | # preferences file (or registry key). It is different than the 136 | # application version so that new app version may use old preferences. 137 | # prefsVersion is the protocol version, prefsLocation becomes part 138 | # of the path (or key) and is more user visable. 139 | 140 | variable prefsVersion 4 141 | variable prefsLocation "2.0" 142 | 143 | # Don't forget previous values for prefsLocation so that we can 144 | # copy forward preferences/keys from older versions. 145 | 146 | variable prefsLocationHistory "2.0 1.5 1.4.1 1.4 1.3 1.2" 147 | 148 | # The root location of the preferences/license file(s). The default 149 | # path to the license file is generated using $prefsRoot and 150 | # $prefsLocation. We split them up so that we can use different 151 | # locations if needed (testing licenses, for example) 152 | 153 | variable prefsRoot {} 154 | if {$tcl_platform(platform) == "windows"} { 155 | set prefsRoot "HKEY_CURRENT_USER\\SOFTWARE\\Scriptics\\$productName" 156 | } else { 157 | set prefsRoot [file join ~ .$productName] 158 | } 159 | 160 | # Values that contain various project related file extensions 161 | 162 | variable debuggerProjFileExt ".tpj" 163 | variable authorProjFileExt ".apj" 164 | variable docHandlerFileExt ".xdh" 165 | 166 | # This is the product ID that is used, along with the versString 167 | # to verify the license. This variable cannot exceed twelve (12) 168 | # bits, that is a maximum of 4096. Increment the number and ensure 169 | # that the no product ID is ever reused. 170 | 171 | #variable productID 2024 ;# TclPro 1.1 172 | #variable productID 2050 ;# TclPro 1.2b2 173 | #variable productID 2051 ;# TclPro 1.2, 1.3b1-b4 174 | #variable productID 2052 ;# TclPro 1.3 175 | #variable productID 3000 ;# xmlserver 1.1 176 | #variable productID 2053 ;# TclPro 1.4 177 | variable productID 2054 ;# TclPro 1.4.1 178 | 179 | # Specify the packages for which the .pcx extension files will be sourced. 180 | # Package names match the file rootnames of the pcx files in the 181 | # tclchecker source dir. 182 | 183 | variable pcxPkgs [list ] 184 | 185 | # Specify the packages for which the .pdx extension files will be sourced. 186 | # Package names match the file rootnames of the pdx files in the 187 | # tcldebugger source dir. 188 | 189 | variable pdxPkgs [list uplevel] 190 | 191 | # Specify the installation directories containing .pcx and .pdx 192 | # extension files to be sourced by the checker and debugger. 193 | 194 | variable pcxPdxDir [file join $installationDir lib] 195 | 196 | # Specify other directories containing .pcx and .pdx extension 197 | # files via the following environment variable: 198 | 199 | variable pcxPdxVar TCLPRO_LOCAL 200 | 201 | # Store location of help file/url for modules in this product. 202 | 203 | variable helpFile 204 | array set helpFile [list tcl "" thisProduct ""] 205 | 206 | set docDir [file join $installationDir doc] 207 | if {$::tcl_platform(platform) == "windows"} { 208 | # Use the help file if it exists. 209 | 210 | set tmp [file join $docDir help "tcl$shortTclVers.hlp"] 211 | if {[file exists $tmp]} { 212 | set helpFile(tcl) $tmp 213 | } 214 | } 215 | 216 | set helpFile(tcl) https://www.tcl.tk/man/tcl8.6/ 217 | 218 | set tmp [file join $docDir html index.html] 219 | if {[file exists $tmp]} { 220 | set helpFile(thisProduct) $tmp 221 | } else { 222 | set helpFile(thisProduct) \ 223 | http://www.tcl.tk/software/tclpro/doc/TclProUsersGuide14.pdf 224 | } 225 | 226 | # By defining these variables the startup sequence will check licenses 227 | if {0} { 228 | variable verifyLicense 229 | if {[info exist tk_version]} { 230 | set verifyLicense licenseWin::verifyLicense 231 | } else { 232 | set verifyLicense projectInfo::verifyLicense 233 | } 234 | } 235 | } 236 | 237 | # projectInfo::getPreviousPrefslocation -- 238 | # 239 | # This command will find the prefsLocation that was in use 240 | # before the specified version. 241 | # 242 | # Arguments: 243 | # curVer "current" specified version. If not specified, the 244 | # actual current version is used. 245 | # 246 | # Results: 247 | # Returns the prefsLocation that occurred before the specified 248 | # prefsLocation. eg. Specifying 1.3 will cause the routine to 249 | # return 1.2 Returns an empty string if there was no previous 250 | # prefsLocation or if the "current" preference location could not 251 | # be found. 252 | 253 | proc projectInfo::getPreviousPrefslocation {{curLoc {}}} { 254 | variable prefsLocation 255 | variable prefsLocationHistory 256 | 257 | if {[string length $curLoc] == 0} { 258 | set curLoc $prefsLocation 259 | } 260 | 261 | set prefIndex [lsearch $prefsLocationHistory $curLoc] 262 | 263 | if {$prefIndex == -1} { 264 | return {} 265 | } 266 | 267 | incr prefIndex 268 | 269 | return [lindex $prefsLocationHistory $prefIndex] 270 | } 271 | 272 | # projectInfo::printCopyrightOnly -- 273 | # 274 | # This command will print the copyright information to the tty 275 | # unless the printCopyright variable in this package has been 276 | # set to 0. We may want to rename 'printCopyright' below and 277 | # have it call this routine at a loater date. 278 | # 279 | # Arguments: 280 | # name Product name - which will appear in the copyright line. 281 | # extra Extra copyright lines that may be specific to an exe. 282 | # 283 | # Results: 284 | # None. Information may be printed to stdout. 285 | 286 | proc projectInfo::printCopyrightOnly {name {extra {}}} { 287 | variable printCopyright 288 | variable versString 289 | variable copyright 290 | 291 | if {$printCopyright} { 292 | puts stdout "$name -- Version $versString" 293 | puts stdout $copyright 294 | 295 | if {$extra != ""} { 296 | puts stdout $extra 297 | } 298 | 299 | puts stdout {} 300 | } 301 | } 302 | 303 | # projectInfo::printCopyright -- 304 | # 305 | # This command will print the copyright information to the tty 306 | # unless the printCopyright variable in this package has been 307 | # set to 0. It will also confirm that the user has the correct 308 | # license to run this product. 309 | # 310 | # Arguments: 311 | # name Product name - which will appear in the copyright line. 312 | # extra Extra copyright lines that may be specific to an exe. 313 | # 314 | # Results: 315 | # None. Information may be printed to stdout. 316 | 317 | proc projectInfo::printCopyright {name {extra {}}} { 318 | variable printCopyright 319 | variable versString 320 | variable copyright 321 | 322 | if {$printCopyright} { 323 | puts stdout "$name -- Version $versString" 324 | puts stdout $copyright 325 | 326 | if {$extra != ""} { 327 | puts stdout $extra 328 | } 329 | } 330 | if {[info exist projectInfo::verifyCommand]} { 331 | $projectInfo::verifyCommand $name $projectInfo::versString $projectInfo::productID \ 332 | registeredName 333 | } 334 | 335 | if {$printCopyright && [info exist registeredName]} { 336 | puts stdout "This product is registered to: $registeredName" 337 | } 338 | if {$printCopyright} { 339 | puts stdout {} 340 | } 341 | } 342 | 343 | -------------------------------------------------------------------------------- /src/tcl/lib/tcldebugger/appLaunch.tcl: -------------------------------------------------------------------------------- 1 | # appLaunch.tcl -- 2 | # 3 | # This script takes care of initializing the nub and invoking the 4 | # client application script when an application is being launched 5 | # from the debugger. 6 | # 7 | # NOTE: This file is for internal use only and may change without 8 | # notice. The contents should not be modified in any way. 9 | # 10 | # Copyright (c) 1998-2000 Ajuba Solutions 11 | # Copyright (c) 2017 Forward Folio LLC 12 | # See the file "license.terms" for information on usage and redistribution of this file. 13 | # 14 | 15 | # DbgNub_Main -- 16 | # 17 | # Initializes the nub and invokes the client script. 18 | # 19 | # Arguments: 20 | # None. 21 | # 22 | # Results: 23 | # None. 24 | 25 | proc DbgNub_Main {} { 26 | global argc argv0 argv errorCode errorInfo tcl_version 27 | 28 | if {$argc < 4} { 29 | error "$argv0 needs cmd line args: hostname port scriptName data ?args?" 30 | } 31 | 32 | # Parse command line arguments 33 | 34 | set libDir [file dirname $argv0] 35 | set host [lindex $argv 0] 36 | set port [lindex $argv 1] 37 | set script [lindex $argv 2] 38 | set data [lindex $argv 3] 39 | set argList [lrange $argv 4 end] 40 | 41 | # Set up replacement arguments so the client script doesn't see the 42 | # appLaunch arguments. 43 | 44 | set argv0 $script 45 | set argv $argList 46 | set argc [llength $argList] 47 | 48 | # The following code needs to be kept in sync with initdebug.tcl 49 | 50 | if {[catch {set socket [socket $host $port]}] != 0} { 51 | exit 1 52 | } 53 | fconfigure $socket -blocking 1 -translation binary 54 | 55 | # On 8.1 and later versions we should ensure the socket is not doing 56 | # any encoding translations. 57 | 58 | if {$tcl_version >= 8.1} { 59 | fconfigure $socket -encoding utf-8 60 | } 61 | 62 | # Attach to the debugger as a local app. 63 | 64 | set msg [list HELLO 1.0 $tcl_version $data] 65 | puts $socket [string length $msg] 66 | puts -nonewline $socket $msg 67 | flush $socket 68 | 69 | # Get the rest of the nub library and evaluate it in the current scope. 70 | # Note that the nub code assumes there will be a "socket" variable that 71 | # contains the debugger socket channel. 72 | 73 | if {[gets $socket bytes] == -1} { 74 | exit 1 75 | } 76 | set msg [read $socket $bytes] 77 | eval [lindex $msg 1] 78 | return 79 | } 80 | 81 | DbgNub_Main 82 | source $argv0 83 | -------------------------------------------------------------------------------- /src/tcl/lib/tcldebugger/blend.pdx: -------------------------------------------------------------------------------- 1 | # blend.pdx -- 2 | # 3 | # This file implements the TclPro Debugger extension for the 4 | # TclBlend extension. 5 | # 6 | # Copyright (c) 1998-2000 Ajuba Solutions 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | # Register the TclBlend extension 12 | 13 | instrument::addExtension 2.0 {java} 14 | 15 | namespace eval blend { 16 | } 17 | 18 | # Register handlers for each of the TclBlend commands 19 | 20 | instrument::addCommand java::bind {parseSimpleArgs 1 3 {parseWord parseWord parseBody}} 21 | instrument::addCommand try {parseSimpleArgs 1 -1 blend::parseTry} 22 | instrument::addCommand java::try {parseSimpleArgs 1 -1 blend::parseTry} 23 | 24 | # blend::parseTry -- 25 | # 26 | # This routine wraps the java::try command. 27 | # Parse args of the pattern: 28 | # ?catch exception_pair script ... ? ?finally script? 29 | # 30 | # Arguments: 31 | # tokens The list of word tokens for the current command. 32 | # index The index of the next word to be parsed. 33 | # 34 | # Results: 35 | # Returns the index of the last token + 1 (all have been parsed). 36 | 37 | proc blend::parseTry {tokens index} { 38 | # The first script argument is required. 39 | 40 | set argList [list parseBody] 41 | 42 | set i [expr {$index + 1}] 43 | set argc [llength $tokens] 44 | while {$i < $argc} { 45 | # At this point in the loop, there are 3X + 2 more args. 46 | 47 | if {$i == [expr {$argc - 2}]} { 48 | lappend argList parseWord parseBody 49 | incr i 2 50 | } else { 51 | lappend argList parseWord parseWord parseBody 52 | incr i 3 53 | } 54 | } 55 | 56 | # in case "try" was call with wrong num args, just check the extras 57 | # against parseWord for now--the user will get a Tcl runtime exception. 58 | 59 | lappend argList parseWord 60 | 61 | return [instrument::parseSimpleArgs 1 -1 $argList $tokens $index] 62 | } 63 | -------------------------------------------------------------------------------- /src/tcl/lib/tcldebugger/block.tcl: -------------------------------------------------------------------------------- 1 | # block.tcl -- 2 | # 3 | # This file contains functions that maintain the block data structure. 4 | # 5 | # Copyright (c) 1998-2000 Ajuba Solutions 6 | # Copyright (c) 2017 Forward Folio LLC 7 | # See the file "license.terms" for information on usage and redistribution of this file. 8 | # 9 | 10 | package provide blk 1.0 11 | namespace eval blk { 12 | # block data type -- 13 | # 14 | # A block encapsulates the state associated with a unit of 15 | # instrumented code. Each block is represented by a Tcl array 16 | # whose name is of the form blk and contains the 17 | # following elements: 18 | # file The name of the file that contains this 19 | # block. May be null if the block contains 20 | # dynamic code. 21 | # script The original uninstrumented script. 22 | # version A version counter for the contents of 23 | # the block. 24 | # instrumented Indicates that a block represents instrumented 25 | # code. 26 | # lines A list of line numbers in the script that 27 | # contain the start of a debugged statement. 28 | # These are valid breakpoint lines. 29 | # 30 | # Fields: 31 | # blockCounter This counter is used to generate block names. 32 | # blockFiles This array maps from file names to blocks. 33 | # blkTemp This block is the shared temporary block. It is 34 | # used for showing uninstrumented code. 35 | 36 | variable blockCounter 0 37 | array set blockFiles {} 38 | array set blkTemp {file {} version 0 instrumented 0 script {} lines {}} 39 | } 40 | # end namespace blk 41 | 42 | # blk::makeBlock -- 43 | # 44 | # Retrieve the block associated with a file, creating a new 45 | # block if necessary. 46 | # 47 | # Arguments: 48 | # file The file that contains the block or {} for dynamic blocks. 49 | # 50 | # Results: 51 | # Returns the block identifier. 52 | 53 | proc blk::makeBlock {file} { 54 | variable blockCounter 55 | variable blockFiles 56 | 57 | # check to see if the block already exists 58 | 59 | set formatFile [system::formatFilename $file] 60 | if {[info exists blockFiles($formatFile)]} { 61 | return $blockFiles($formatFile) 62 | } 63 | 64 | # find an unallocated block number and create the array 65 | 66 | incr blockCounter 67 | while {[info exists ::blk::blk$blockCounter]} { 68 | incr blockCounter 69 | } 70 | array set ::blk::blk${blockCounter} [list \ 71 | file $file \ 72 | version 0 \ 73 | instrumented 0 lines {}] 74 | 75 | # don't create an entry for dynamic blocks 76 | 77 | if {$file != ""} { 78 | set blockFiles($formatFile) $blockCounter 79 | } 80 | return $blockCounter 81 | } 82 | 83 | # blk::release -- 84 | # 85 | # Release the storage associated with one or more blocks. 86 | # 87 | # Arguments: 88 | # args The blocks to release, "dynamic" to release all dynamic 89 | # blocks, or "all" to release all blocks. 90 | # 91 | # Results: 92 | # None. 93 | 94 | proc blk::release {args} { 95 | if {$args == "dynamic"} { 96 | foreach block [info var ::blk::blk*] { 97 | if {[set ${block}(file)] == ""} { 98 | unset $block 99 | } 100 | } 101 | } elseif {$args == "all"} { 102 | if {[info exists ::blk::blockFiles]} { 103 | unset ::blk::blockFiles 104 | } 105 | set all [info var ::blk::blk*] 106 | if {$all != ""} { 107 | eval unset $all 108 | } 109 | } else { 110 | foreach block $args { 111 | if {! [info exists ::blk::blk$block]} { 112 | continue 113 | } 114 | set file [getFile $block] 115 | if {$file != ""} { 116 | unset ::blk::blockFiles([system::formatFilename $file]) 117 | } 118 | unset ::blk::blk$block 119 | } 120 | } 121 | 122 | if {! [info exists ::blk::blkTemp]} { 123 | array set ::blk::blkTemp {file {} version 0 instrumented 0 script {} 124 | lines {}} 125 | } 126 | } 127 | 128 | # blk::exists -- 129 | # 130 | # Determine if the block still exists. 131 | # 132 | # Arguments: 133 | # blockNum The block to check for existence. 134 | # 135 | # Results: 136 | # Return 1 if the block exists. 137 | 138 | proc blk::exists {blockNum} { 139 | return [info exists ::blk::blk${blockNum}(instrumented)] 140 | } 141 | 142 | 143 | # blk::getSource -- 144 | # 145 | # Return the script associated with a block. If block's script 146 | # has never been set, open the file and read the contents. 147 | # 148 | # Arguments: 149 | # blockNum The block number. 150 | # 151 | # Results: 152 | # Returns the script. 153 | 154 | proc blk::getSource {blockNum} { 155 | upvar #0 ::blk::blk$blockNum block 156 | 157 | if {[info exists block(script)]} { 158 | return $block(script) 159 | } elseif {$block(file) != ""} { 160 | set fd [open $block(file) r] 161 | set script [read $fd] 162 | close $fd 163 | incr block(version) 164 | return $script 165 | } else { 166 | return "" 167 | } 168 | } 169 | 170 | # blk::getFile -- 171 | # 172 | # Return the name associated with the given block. 173 | # 174 | # Arguments: 175 | # blockNum The block number. 176 | # 177 | # Results: 178 | # Returns the file name or {} if the block is dynamic. 179 | 180 | proc blk::getFile {blockNum} { 181 | return [set ::blk::blk${blockNum}(file)] 182 | } 183 | 184 | # blk::getLines -- 185 | # 186 | # Return the list of line numbers that represent valid 187 | # break-points for this block. If the block does not 188 | # exist or the block is not instrumented we return -1. 189 | # 190 | # Arguments: 191 | # blockNum The block number. 192 | # 193 | # Results: 194 | # Returns a list of line numbers. 195 | 196 | proc blk::getLines {blockNum} { 197 | if {! [info exists ::blk::blk${blockNum}(instrumented)] \ 198 | || ! [set ::blk::blk${blockNum}(instrumented)]} { 199 | return -1 200 | } 201 | return [set ::blk::blk${blockNum}(lines)] 202 | } 203 | 204 | # blk::getRanges -- 205 | # 206 | # Return the list of ranges that represent valid 207 | # break-pints for this block. If the block does not 208 | # exist or the block is not instrumented, we return -1. 209 | # 210 | # Arguments: 211 | # blockNum The block number. 212 | # 213 | # Results: 214 | # Returns a list of range numbers. 215 | 216 | proc blk::getRanges {blockNum} { 217 | if {! [info exists ::blk::blk${blockNum}(instrumented)]} { 218 | return -1 219 | } 220 | if {! [set ::blk::blk${blockNum}(instrumented)]} { 221 | return -1 222 | } 223 | return [lsort [set ::blk::blk${blockNum}(ranges)]] 224 | } 225 | 226 | # blk::Instrument -- 227 | # 228 | # Set the source script associated with a block and return the 229 | # instrumented form. 230 | # 231 | # Arguments: 232 | # blockNum The block number. 233 | # script The new source for the block that should be 234 | # instrumented. 235 | # 236 | # Results: 237 | # Returns the instrumented script. 238 | 239 | proc blk::Instrument {blockNum script} { 240 | SetSource $blockNum $script 241 | set script [instrument::Instrument $blockNum] 242 | 243 | # Don't mark the block as instrumented unless we have successfully 244 | # completed instrumentation. 245 | 246 | if {$script != ""} { 247 | set ::blk::blk${blockNum}(instrumented) 1 248 | 249 | # Compute the sorted list of line numbers containing statements. 250 | # We need to suppress duplicates since there may be more than one 251 | # statement per line. 252 | 253 | if {[info exists tmp]} { 254 | unset tmp 255 | } 256 | foreach x $::instrument::lines { 257 | set tmp($x) "" 258 | } 259 | 260 | # Ensure that the lines are in numerically ascending order. 261 | 262 | set ::blk::blk${blockNum}(lines) [lsort -integer [array names tmp]] 263 | 264 | # Get the coverable ranges for this block. 265 | 266 | set ::blk::blk${blockNum}(ranges) $::instrument::ranges 267 | } 268 | return $script 269 | } 270 | 271 | # blk::isInstrumented -- 272 | # 273 | # Test whether a block has been instrumented. 274 | # 275 | # Arguments: 276 | # blockNum The block number. 277 | # 278 | # Results: 279 | # Returns 1 if the block is instrumented else 0. 280 | 281 | proc blk::isInstrumented {blockNum} { 282 | if {[catch {set ::blk::blk${blockNum}(instrumented)} result]} { 283 | return 0 284 | } 285 | return $result 286 | } 287 | 288 | # blk::unmarkInstrumented -- 289 | # 290 | # Mark all the instrumented blocks as uninstrumented. If it's 291 | # a block to a file remove the source. 292 | # 293 | # Arguments: 294 | # None. 295 | # 296 | # Results: 297 | # None. 298 | 299 | proc blk::unmarkInstrumented {} { 300 | foreach block [info var ::blk::blk*] { 301 | if {[set ${block}(instrumented)] == 1} { 302 | set ${block}(instrumented) 0 303 | if {[set ${block}(file)] != ""} { 304 | unset ${block}(script) 305 | } 306 | } 307 | } 308 | return 309 | } 310 | 311 | # blk::getVersion -- 312 | # 313 | # Retrieve the source version for the block. 314 | # 315 | # Arguments: 316 | # blockNum The block number. 317 | # 318 | # Results: 319 | # Returns the version number. 320 | 321 | proc blk::getVersion {blockNum} { 322 | return [set ::blk::blk${blockNum}(version)] 323 | } 324 | 325 | # blk::getFiles -- 326 | # 327 | # This function retrieves all of the blocks that are associated 328 | # with files. 329 | # 330 | # Arguments: 331 | # None. 332 | # 333 | # Results: 334 | # Returns a list of blocks. 335 | 336 | proc blk::getFiles {} { 337 | set result {} 338 | foreach name [array names ::blk::blockFiles] { 339 | lappend result $::blk::blockFiles($name) 340 | } 341 | return $result 342 | } 343 | 344 | # blk::SetSource -- 345 | # 346 | # This routine sets the script attribute of a block and incremenets 347 | # the version number. 348 | # 349 | # Arguments: 350 | # blockNum The block number. 351 | # script The new contents of the block. 352 | # 353 | # Results: 354 | # None. 355 | 356 | proc blk::SetSource {blockNum script} { 357 | set ::blk::blk${blockNum}(script) $script 358 | incr ::blk::blk${blockNum}(version) 359 | return 360 | } 361 | 362 | # blk::isDynamic -- 363 | # 364 | # Check whether the current block is associated with a file or 365 | # is a dynamic block. 366 | # 367 | # Arguments: 368 | # blockNum The block number. 369 | # 370 | # Results: 371 | # Returns 1 if the block is not associated with a file. 372 | 373 | proc blk::isDynamic {blockNum} { 374 | return [expr {[set ::blk::blk${blockNum}(file)] == ""}] 375 | } 376 | 377 | -------------------------------------------------------------------------------- /src/tcl/lib/tcldebugger/break.tcl: -------------------------------------------------------------------------------- 1 | # break.tcl -- 2 | # 3 | # This file implements the breakpoint object API. 4 | # 5 | # Copyright (c) 1998-2000 Ajuba Solutions 6 | # Copyright (c) 2017 Forward Folio LLC 7 | # See the file "license.terms" for information on usage and redistribution of this file. 8 | # 9 | 10 | package provide break 1.0 11 | namespace eval break { 12 | # breakpoint data type -- 13 | # 14 | # A breakpoint object encapsulates the state associated with a 15 | # breakpoint. Each breakpoint is represented by a Tcl array 16 | # whose name is of the form break where is 17 | # L for line-based breakpoints and V for variable breakpoints. 18 | # Each array contains the following elements: 19 | # state Either enabled or disabled. 20 | # test The script in conditional breakpoints. 21 | # location The location or trace handle for the 22 | # breakpoint. 23 | # data This field holds arbitrary data associated 24 | # with the breakpoint for use by the GUI. 25 | # 26 | # Fields: 27 | # counter This counter is used to generate breakpoint names. 28 | 29 | variable counter 0 30 | } 31 | # end namespace break 32 | 33 | # break::MakeBreakpoint -- 34 | # 35 | # Create a new breakpoint. 36 | # 37 | # Arguments: 38 | # type One of "line" or "var" 39 | # where Location for line breakpoints; trace handle for 40 | # variable breakpoints. 41 | # test Optional. Script to use for conditional breakpoint. 42 | # 43 | # Results: 44 | # Returns a breakpoint identifier. 45 | 46 | proc break::MakeBreakpoint {type location {test {}}} { 47 | variable counter 48 | 49 | if {$type == "line"} { 50 | set type L 51 | } else { 52 | set type V 53 | } 54 | 55 | # find an unallocated breakpointer number and create the array 56 | 57 | incr counter 58 | while {[info exists ::break::break$type$counter]} { 59 | incr counter 60 | } 61 | set name $type$counter 62 | array set ::break::break$name \ 63 | [list data {} location $location state enabled test $test] 64 | return $name 65 | } 66 | 67 | # break::Release -- 68 | # 69 | # Release the storage associated with one or more breakpoints. 70 | # 71 | # Arguments: 72 | # breakList The breakpoints to release, or "all". 73 | # 74 | # Results: 75 | # None. 76 | 77 | proc break::Release {breakList} { 78 | if {$breakList == "all"} { 79 | # Release all breakpoints 80 | set all [info vars ::break::break*] 81 | if {$all != ""} { 82 | eval unset $all 83 | } 84 | } else { 85 | foreach breakpoint $breakList { 86 | if {[info exist ::break::break$breakpoint]} { 87 | unset ::break::break$breakpoint 88 | } 89 | } 90 | } 91 | return 92 | } 93 | 94 | # break::getState -- 95 | # 96 | # Return the breakpoint state. 97 | # 98 | # Arguments: 99 | # breakpoint The breakpoint identifier. 100 | # 101 | # Results: 102 | # Returns one of enabled or disabled. 103 | 104 | proc break::getState {breakpoint} { 105 | return [set ::break::break${breakpoint}(state)] 106 | } 107 | 108 | # break::getLocation -- 109 | # 110 | # Return the breakpoint location. 111 | # 112 | # Arguments: 113 | # breakpoint The breakpoint identifier. 114 | # 115 | # Results: 116 | # Returns the breakpoint location. 117 | 118 | proc break::getLocation {breakpoint} { 119 | return [set ::break::break${breakpoint}(location)] 120 | } 121 | 122 | 123 | # break::getTest -- 124 | # 125 | # Return the breakpoint test. 126 | # 127 | # Arguments: 128 | # breakpoint The breakpoint identifier. 129 | # 130 | # Results: 131 | # Returns the breakpoint test. 132 | 133 | proc break::getTest {breakpoint} { 134 | return [set ::break::break${breakpoint}(test)] 135 | } 136 | 137 | # break::getType -- 138 | # 139 | # Return the type of the breakpoint. 140 | # 141 | # Arguments: 142 | # breakpoint The breakpoint identifier. 143 | # 144 | # Results: 145 | # Returns the breakpoint type; one of "line" or "var". 146 | 147 | proc break::getType {breakpoint} { 148 | switch [string index $breakpoint 0] { 149 | V { 150 | return "var" 151 | } 152 | L { 153 | return "line" 154 | } 155 | } 156 | error "Invalid breakpoint type" 157 | } 158 | 159 | 160 | # break::SetState -- 161 | # 162 | # Change the breakpoint state. 163 | # 164 | # Arguments: 165 | # breakpoint The breakpoint identifier. 166 | # state One of enabled or disabled. 167 | # 168 | # Results: 169 | # None. 170 | 171 | proc break::SetState {breakpoint state} { 172 | set ::break::break${breakpoint}(state) $state 173 | return 174 | } 175 | 176 | # break::getData -- 177 | # 178 | # Retrieve the client data field. 179 | # 180 | # Arguments: 181 | # breakpoint The breakpoint identifier. 182 | # 183 | # Results: 184 | # Returns the data field. 185 | 186 | proc break::getData {breakpoint} { 187 | return [set ::break::break${breakpoint}(data)] 188 | } 189 | 190 | # break::setData -- 191 | # 192 | # Set the client data field. 193 | # 194 | # Arguments: 195 | # breakpoint The breakpoint identifier. 196 | # 197 | # Results: 198 | # None. 199 | 200 | proc break::setData {breakpoint data} { 201 | set ::break::break${breakpoint}(data) $data 202 | return 203 | } 204 | 205 | # break::GetLineBreakpoints -- 206 | # 207 | # Returns a list of all line-based breakpoint indentifiers. If the 208 | # optional location is specified, only breakpoints set at that 209 | # location are returned. 210 | # 211 | # Arguments: 212 | # location Optional. The location of the breakpoint to get. 213 | # 214 | # Results: 215 | # Returns a list of all line-based breakpoint indentifiers. 216 | 217 | proc break::GetLineBreakpoints {{location {}}} { 218 | set result {} 219 | foreach breakpoint [info vars ::break::breakL*] { 220 | if {($location == "") \ 221 | || [loc::match $location [set ${breakpoint}(location)]]} { 222 | lappend result $breakpoint 223 | } 224 | } 225 | 226 | regsub -all {::break::break} $result {} result 227 | return $result 228 | } 229 | 230 | # break::GetVarBreakpoints -- 231 | # 232 | # Returns a list of all variable-based breakpoint indentifiers 233 | # for a specified variable trace. 234 | # 235 | # Arguments: 236 | # handle The trace handle. 237 | # 238 | # Results: 239 | # A list of breakpoint identifiers. 240 | 241 | proc break::GetVarBreakpoints {{handle {}}} { 242 | set result {} 243 | foreach breakpoint [info vars ::break::breakV*] { 244 | if {($handle == "") \ 245 | || ([set ${breakpoint}(location)] == $handle)} { 246 | lappend result $breakpoint 247 | } 248 | } 249 | regsub -all {::break::break} $result {} result 250 | return $result 251 | } 252 | 253 | # break::preserveBreakpoints -- 254 | # 255 | # Generate a persistent representation for all line-based 256 | # breakpoints so they can be stored in the user preferences. 257 | # 258 | # Arguments: 259 | # varName Name of variable where breakpoint info should 260 | # be stored. 261 | # 262 | # Results: 263 | # None. 264 | 265 | proc break::preserveBreakpoints {varName} { 266 | upvar $varName data 267 | set data {} 268 | foreach bp [GetLineBreakpoints] { 269 | set location [getLocation $bp] 270 | set file [blk::getFile [loc::getBlock $location]] 271 | set line [loc::getLine $location] 272 | if {$file != ""} { 273 | lappend data [list $file $line [getState $bp] \ 274 | [getTest $bp]] 275 | } 276 | } 277 | return 278 | } 279 | 280 | # break::restoreBreakpoints -- 281 | # 282 | # Recreate a set of breakpoints from a previously preserved list. 283 | # 284 | # Arguments: 285 | # data The data generated by a previous call to 286 | # preserveBreakpoints. 287 | # 288 | # Results: 289 | # None. 290 | 291 | proc break::restoreBreakpoints {data} { 292 | foreach bp $data { 293 | set block [blk::makeBlock [lindex $bp 0]] 294 | set location [loc::makeLocation $block [lindex $bp 1]] 295 | SetState [MakeBreakpoint "line" $location [lindex $bp 3]] \ 296 | [lindex $bp 2] 297 | } 298 | return 299 | } 300 | -------------------------------------------------------------------------------- /src/tcl/lib/tcldebugger/evalWin.tcl: -------------------------------------------------------------------------------- 1 | # evalWin.tcl -- 2 | # 3 | # The file implements the Debuger interface to the 4 | # TkCon console (or whats left of it...) 5 | # 6 | # Copyright (c) 1998-2000 Ajuba Solutions 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | namespace eval evalWin { 12 | 13 | # The handle to the text widget where commands are entered. 14 | 15 | variable evalText 16 | 17 | # The handle to the combo box that contains the list of 18 | # valid level to eval commands in. 19 | 20 | variable levelCombo 21 | 22 | # Used to delay UI changes do to state change. 23 | variable afterID 24 | } 25 | 26 | # evalWin::showWindow -- 27 | # 28 | # Show the Eval Window. If it already exists, just raise 29 | # it to the foreground. Otherwise, create a new eval window. 30 | # 31 | # Arguments: 32 | # None. 33 | # 34 | # Results: 35 | # The toplevel window name for the Eval Window. 36 | 37 | proc evalWin::showWindow {} { 38 | # If the window already exists, show it, otherwise 39 | # create it from scratch. 40 | 41 | if {[info command $gui::gui(evalDbgWin)] == $gui::gui(evalDbgWin)} { 42 | # evalWin::updateWindow 43 | wm deiconify $gui::gui(evalDbgWin) 44 | focus $evalWin::evalText 45 | return $gui::gui(evalDbgWin) 46 | } else { 47 | evalWin::createWindow 48 | evalWin::updateWindow 49 | focus $evalWin::evalText 50 | return $gui::gui(evalDbgWin) 51 | } 52 | } 53 | 54 | # evalWin::createWindow -- 55 | # 56 | # Create the Eval Window. 57 | # 58 | # Arguments: 59 | # None. 60 | # 61 | # Results: 62 | # None. 63 | 64 | proc evalWin::createWindow {} { 65 | variable evalText 66 | variable levelCombo 67 | 68 | set bd 2 69 | set pad 6 70 | 71 | set top [toplevel $gui::gui(evalDbgWin)] 72 | ::guiUtil::positionWindow $top 400x250 73 | wm protocol $top WM_DELETE_WINDOW "wm withdraw $top" 74 | wm minsize $top 100 100 75 | wm title $top "Eval Console" 76 | wm transient $top $gui::gui(mainDbgWin) 77 | 78 | # Create the level indicator and combo box. 79 | 80 | set mainFrm [frame $top.mainFrm -bd $bd -relief raised] 81 | set levelFrm [frame $mainFrm.levelFrm] 82 | set levelLbl [label $levelFrm.levelLbl -text "Stack Level:"] 83 | set levelCombo [guiUtil::ComboBox $levelFrm.levelCombo -ewidth 8 \ 84 | -textvariable gui::gui(evalLevelVar) -strict 1 \ 85 | -listheight 1 -listwidth 8 -listexportselection 0] 86 | set closeBut [button $levelFrm.closeBut -text "Close" -width 10 \ 87 | -command {destroy $gui::gui(evalDbgWin)}] 88 | pack $levelLbl -side left 89 | pack $levelCombo -side left -padx 3 90 | pack $closeBut -side right 91 | 92 | # Place a separating line between the var info and the 93 | # value of the var. 94 | 95 | set sepFrm [frame $mainFrm.sep1 -bd $bd -relief groove -height $bd] 96 | 97 | # Create the text widget that will be the eval console. 98 | 99 | set evalFrm [frame $mainFrm.evalFrm] 100 | set evalText [tkCon::InitUI $evalFrm Console] 101 | 102 | pack $levelFrm -fill x -padx $pad -pady $pad 103 | pack $sepFrm -fill x -padx $pad -pady $pad 104 | pack $evalFrm -fill both -expand true -padx $pad -pady $pad 105 | pack $mainFrm -fill both -expand true -padx $pad -pady $pad 106 | 107 | bind::addBindTags $evalText evalDbgWin 108 | bind::addBindTags $levelCombo evalDbgWin 109 | bind::commonBindings evalDbgWin {} 110 | bind $evalText { 111 | evalWin::moveLevel -1; break 112 | } 113 | bind $evalText { 114 | evalWin::moveLevel 1; break 115 | } 116 | foreach num [list 0 1 2 3 4 5 6 7 8 9] { 117 | bind $evalText " 118 | evalWin::requestLevel $num; break 119 | " 120 | } 121 | if {[gui::getCurrentState] == "running"} { 122 | bind::addBindTags $evalText disableKeys 123 | evalWin::resetWindow 124 | } 125 | bind $top "$closeBut invoke; break" 126 | } 127 | 128 | # evalWin::updateWindow -- 129 | # 130 | # Update the display of the Eval Window. 131 | # 132 | # Arguments: 133 | # None. 134 | # 135 | # Results: 136 | # None. 137 | 138 | proc evalWin::updateWindow {} { 139 | variable evalText 140 | variable levelCombo 141 | variable afterID 142 | 143 | if {![winfo exists $gui::gui(evalDbgWin)]} { 144 | return 145 | } 146 | 147 | if {[info exists afterID]} { 148 | after cancel $afterID 149 | unset afterID 150 | } 151 | 152 | # Enable typing in the console and remove the disabled 153 | # look of the console by removing the disabled tags. 154 | 155 | $evalText tag remove disable 0.0 "end + 1 lines" 156 | bind::removeBindTag $evalWin::evalText disableKeys 157 | 158 | set state [gui::getCurrentState] 159 | if {$state == "stopped"} { 160 | # Add the list of valid levels to the level combo box 161 | # and set the display in the combo entry to the top 162 | # stack level. 163 | 164 | set thisLevel $gui::gui(evalLevelVar) 165 | $levelCombo del 0 end 166 | set levels [evalWin::getLevels] 167 | eval {$levelCombo add} $levels 168 | $evalText configure -state normal 169 | 170 | # Set the default level. If the "stopped" event was generated 171 | # by a "result" break type, use the last level as long as it 172 | # still exists. Otherwise use the top-most level. 173 | 174 | set lastLevel [lindex $levels end] 175 | if {([gui::getCurrentBreak] == "result") && $thisLevel < $lastLevel} { 176 | set gui::gui(evalLevelVar) $thisLevel 177 | } else { 178 | set gui::gui(evalLevelVar) $lastLevel 179 | } 180 | } elseif {$state == "running"} { 181 | # Append the bindtag that will disable key strokes. 182 | bind::addBindTags $evalText disableKeys 183 | set afterID [after $gui::afterTime ::evalWin::resetWindow] 184 | } else { 185 | evalWin::resetWindow 186 | } 187 | } 188 | 189 | # evalWin::resetWindow -- 190 | # 191 | # Reset the display of the Eval Window. If the message 192 | # passed in is not empty, display the contents of the 193 | # message in the evalText window. 194 | # 195 | # Arguments: 196 | # msg If this is not an empty string then display this 197 | # message in the evatText window. 198 | # 199 | # Results: 200 | # None. 201 | 202 | proc evalWin::resetWindow {{msg {}}} { 203 | variable evalText 204 | variable levelCombo 205 | 206 | if {![winfo exists $gui::gui(evalDbgWin)]} { 207 | return 208 | } 209 | 210 | $levelCombo del 0 end 211 | $evalText configure -state disabled 212 | $evalText tag add disable 0.0 "end + 1 lines" 213 | } 214 | 215 | # evalWin::evalCmd -- 216 | # 217 | # Evaluate the next command in the evalText window. 218 | # This proc is called by the TkCon code defined in 219 | # tkcon.tcl. 220 | # 221 | # Arguments: 222 | # cmd The command to evaluate. 223 | # 224 | # Results: 225 | # The "pid" of the command. 226 | 227 | proc evalWin::evalCmd {cmd} { 228 | return [gui::run [list dbg::evaluate $gui::gui(evalLevelVar) $cmd]] 229 | } 230 | 231 | # evalWin::evalResult -- 232 | # 233 | # Handler for the "result" message sent from the nub. 234 | # Pass the data to TkCon to display the result. 235 | # 236 | # Arguments: 237 | # id The "pid" of the command. 238 | # code Standard Tcl result code. 239 | # result The result of evaluation. 240 | # errCode The errorCode of the eval. 241 | # errInfo The stack trace of the error. 242 | # 243 | # Results: 244 | # None. 245 | 246 | proc evalWin::evalResult {id code result errCode errInfo} { 247 | set code [code::binaryClean $code] 248 | set result [code::binaryClean $result] 249 | set errCode [code::binaryClean $errCode] 250 | set errInfo [code::binaryClean $errInfo] 251 | 252 | tkCon::EvalResult $id $code $result $errCode $errInfo 253 | } 254 | 255 | # evalWin::moveLevel -- 256 | # 257 | # Move the current eval level up or down within range 258 | # of acceptable levels. 259 | # 260 | # Arguments: 261 | # amount The amount to increment/decrement to the 262 | # current level. 263 | # 264 | # Results: 265 | # None. 266 | 267 | proc evalWin::moveLevel {amount} { 268 | variable levelCombo 269 | 270 | set level [expr {[$levelCombo get] + $amount}] 271 | set last [lindex [evalWin::getLevels] end] 272 | 273 | if {$last == {}} { 274 | return 275 | } 276 | if {$level < 0} { 277 | set level 0 278 | } 279 | if {$level > $last} { 280 | set level $last 281 | } 282 | $levelCombo set $level 283 | } 284 | 285 | # evalWin::requestLevel -- 286 | # 287 | # Request a level, between 0 and 9, to evaluate the next 288 | # command in. If the level is invalid, do nothing. 289 | # 290 | # Arguments: 291 | # level A requested eval level between 0 and 9. 292 | # 293 | # Results: 294 | # None. 295 | 296 | proc evalWin::requestLevel {level} { 297 | variable levelCombo 298 | 299 | if {[lsearch [evalWin::getLevels] $level] >= 0} { 300 | $levelCombo set $level 301 | } 302 | } 303 | 304 | # evalWin::getLevels -- 305 | # 306 | # Get a list of valid level to eval the command in. 307 | # 308 | # Arguments: 309 | # None. 310 | # 311 | # Results: 312 | # None. 313 | 314 | proc evalWin::getLevels {} { 315 | variable evalText 316 | variable levelCombo 317 | 318 | set maxLevel [dbg::getLevel] 319 | set result {} 320 | for {set i 0} {$i <= $maxLevel} {incr i} { 321 | lappend result $i 322 | } 323 | return $result 324 | } 325 | -------------------------------------------------------------------------------- /src/tcl/lib/tcldebugger/file.tcl: -------------------------------------------------------------------------------- 1 | # file.tcl -- 2 | # 3 | # This file implements the file database that maintains 4 | # unique file names and a most-recently-used file list. 5 | # 6 | # Copyright (c) 1998-2000 Ajuba Solutions 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | namespace eval file { 12 | # A list of most-recently-used files in their absolute 13 | # path form. 14 | 15 | variable mruList {} 16 | variable orderedList {} 17 | variable uniqueList {} 18 | 19 | variable updateOrdered 1 20 | variable updateUnique 1 21 | } 22 | 23 | # file::update -- 24 | # 25 | # The list of ordered blocks and unique file names 26 | # is computed lazily and the results are cached 27 | # internally. Call this command when the lists 28 | # need to be re-computed (e.g. after a break.) 29 | # 30 | # Arguments: 31 | # hard Boolean, if true, do a hard update that 32 | # resets the mruList to {}. This should 33 | # only be true when the app is restarted. 34 | # 35 | # Results: 36 | # None. 37 | 38 | proc file::update {{hard 0}} { 39 | variable updateOrdered 1 40 | variable updateUnique 1 41 | if {$hard} { 42 | variable mruList {} 43 | variable orderedList {} 44 | variable uniqueList {} 45 | } 46 | } 47 | 48 | # file::getOrderedBlocks -- 49 | # 50 | # Get an ordered list of open block, where the order 51 | # is most-recently-used, with any remining blocks 52 | # appended to the end. 53 | # 54 | # Arguments: 55 | # None. 56 | # 57 | # Results: 58 | # Returns an ordered list of blocks. The list 59 | # is ordered in a most-recently-used order, then 60 | # any remaining blocks are appended to the end. 61 | 62 | proc file::getOrderedBlocks {} { 63 | variable orderedList 64 | variable updateOrdered 65 | 66 | if {$updateOrdered} { 67 | # Copy the list of MRU blocks into the result. Then 68 | # append any blocks that are not in the MRU list onto 69 | # the end of the new list. 70 | 71 | set orderedList $file::mruList 72 | set blockList [lsort [blk::getFiles]] 73 | foreach block $blockList { 74 | if {[blk::isDynamic $block]} { 75 | continue 76 | } 77 | if {[lsearch -exact $file::mruList $block] < 0} { 78 | lappend orderedList $block 79 | } 80 | } 81 | set updateOrdered 0 82 | } 83 | return $orderedList 84 | } 85 | 86 | # file::getUniqueFiles -- 87 | # 88 | # Get a list of open files where each name is a 89 | # unique name for the file. If there are more than 90 | # one open file with the same name, then the name 91 | # will have a unique identifier. 92 | # 93 | # Arguments: 94 | # None. 95 | # 96 | # Results: 97 | # Returns a list of tuples containing the unique name 98 | # and the block number for the file. The list 99 | # is ordered in a most-recently-used order, then 100 | # any remaining files are appended to the end. 101 | 102 | proc file::getUniqueFiles {} { 103 | variable prevUnique 104 | variable uniqueList 105 | variable updateUnique 106 | 107 | if {$updateUnique} { 108 | set blockList [file::getOrderedBlocks] 109 | set uniqueList {} 110 | foreach block $blockList { 111 | set short [file tail [blk::getFile $block]] 112 | if {[info exists prevUnique($block)]} { 113 | # The file previously recieved a unique 114 | # identifier (i.e "fileName <2>".) To 115 | # maintain consistency, use the old ID. 116 | 117 | set short "$short <$prevUnique($block)>" 118 | } elseif {[info exists unique($short)]} { 119 | # A new file has been loaded that matches 120 | # a previously loaded filename. Bump 121 | # the unique ID and append a unique ID, 122 | # cache the ID for future use. 123 | 124 | incr unique($short) 125 | set prevUnique($block) $unique($short) 126 | set short "$short <$unique($short)>" 127 | } else { 128 | # This is a file w/o a matching name, 129 | # just initialize the unique ID. 130 | 131 | set unique($short) 1 132 | } 133 | lappend uniqueList $short $block 134 | } 135 | set updateUnique 0 136 | } 137 | return $uniqueList 138 | } 139 | 140 | # file::getUniqueFile -- 141 | # 142 | # Get the unique name for the block. 143 | # 144 | # Arguments: 145 | # block The block type for the file. 146 | # 147 | # Results: 148 | # The unique name of the block. 149 | 150 | proc file::getUniqueFile {block} { 151 | foreach {file uBlock} [file::getUniqueFiles] { 152 | if {$uBlock == $block} { 153 | return $file 154 | } 155 | } 156 | return "" 157 | } 158 | 159 | # file::pushBlock -- 160 | # 161 | # Push a new block onto the list of most-recently-used 162 | # blocks. 163 | # 164 | # Arguments: 165 | # block The block of the file to push onto the stack. 166 | # 167 | # Results: 168 | # None. 169 | 170 | proc file::pushBlock {block} { 171 | variable mruList 172 | 173 | if {($block != {}) && (![blk::isDynamic $block])} { 174 | if {[set index [lsearch -exact $mruList $block]] >= 0} { 175 | set mruList [lreplace $mruList $index $index] 176 | } 177 | set mruList [linsert $mruList 0 $block] 178 | file::update 179 | } 180 | } 181 | 182 | # file::getUntitledFile -- 183 | # 184 | # Return a filename of where Name is the default name 185 | # to use and N is the first integer that creates a filename the 186 | # doesn't exist in this directory. 187 | # 188 | # Arguments: 189 | # dir The directory to search finding name conflicts. 190 | # name The default name of the file. 191 | # ext The file extension to append to the filename. 192 | # 193 | # Results: 194 | # A string that is the filename to use. The directory is not 195 | # included in the filename. 196 | 197 | proc file::getUntitledFile {dir name ext} { 198 | for {set i 1} {1} {incr i} { 199 | if {![file exists [file join $dir ${name}${i}${ext}]]} { 200 | return ${name}${i}${ext} 201 | } 202 | } 203 | } 204 | 205 | -------------------------------------------------------------------------------- /src/tcl/lib/tcldebugger/font.tcl: -------------------------------------------------------------------------------- 1 | # font.tcl -- 2 | # 3 | # This file implements the font system that is used by 4 | # all debugger text widgets that require a fixed font. 5 | # 6 | # Copyright (c) 1998-2000 Ajuba Solutions 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | namespace eval font { 12 | variable fontList {} 13 | variable metrics 14 | } 15 | 16 | # font::createFontData -- 17 | # 18 | # Generate a list of fixed fonts on this system. 19 | # 20 | # Arguments: 21 | # None. 22 | # 23 | # Results: 24 | # None. 25 | 26 | proc font::createFontData {} { 27 | variable validFonts 28 | variable fontList 29 | 30 | font create findFixed 31 | set foundFixed 0 32 | set fontList {} 33 | 34 | foreach font [system::getFontList] { 35 | font configure findFixed -family $font -size 10 36 | if {([font metrics findFixed -fixed]) && \ 37 | [font actual findFixed -family] == $font} { 38 | set foundFixed 1 39 | lappend fontList $font 40 | } 41 | } 42 | if {!$foundFixed} { 43 | error "could not locate a fixed font on this system." 44 | } 45 | if {$fontList == {}} { 46 | error "could not find min size a fixed font on this system." 47 | } 48 | set fontList [lsort $fontList] 49 | font delete findFixed 50 | } 51 | 52 | # font::getFonts -- 53 | # 54 | # Return the list of valid fixed fonts. 55 | # 56 | # Arguments: 57 | # None. 58 | # 59 | # Results: 60 | # A list containing valid fonts. 61 | 62 | proc font::getFonts {} { 63 | variable fontList 64 | 65 | if {$fontList == {}} { 66 | font::createFontData 67 | } 68 | return $fontList 69 | } 70 | 71 | # font::configure -- 72 | # 73 | # Set or reset font data the is used by the various widgets. 74 | # 75 | # Arguments: 76 | # font The new font family to use. 77 | # size The requested size of the font. 78 | # 79 | # Results: 80 | # None. The metrics array will be re-initalized with 81 | # new data about the currently selected font. Use the 82 | # font::get command to retrieve font data. 83 | 84 | proc font::configure {font size} { 85 | variable metrics 86 | 87 | set family [font actual [list $font] -family] 88 | if {[lsearch [font names] dbgFixedFont] < 0} { 89 | font create dbgFixedFont -family $family -size $size 90 | font create dbgFixedItalicFont -family $family -size $size \ 91 | -slant italic 92 | font create dbgFixedBoldFont -family $family -size $size -weight bold 93 | } else { 94 | font configure dbgFixedFont -family $family -size $size 95 | font configure dbgFixedItalicFont -family $family -size $size \ 96 | -slant italic 97 | font configure dbgFixedBoldFont -family $family -size $size \ 98 | -weight bold 99 | } 100 | 101 | # Store as much info about the font as possible. Including: 102 | # the actual family and size, font metrics, the same family 103 | # only with italics and bold, and the width of a single 104 | # fixed character. 105 | 106 | if {[info exists metrics]} { 107 | unset metrics 108 | } 109 | array set metrics [font actual dbgFixedFont] 110 | array set metrics [font metrics dbgFixedFont] 111 | set metrics(-font) dbgFixedFont 112 | set metrics(-fontItalic) dbgFixedItalicFont 113 | set metrics(-fontBold) dbgFixedBoldFont 114 | set metrics(-width) [font measure $metrics(-font) "W"] 115 | set metrics(-maxchars) [expr {[winfo screenwidth .]/$metrics(-width)}] 116 | 117 | return [list $font $size] 118 | } 119 | 120 | # font::get -- 121 | # 122 | # Get data about the selected fixed font. 123 | # 124 | # Arguments: 125 | # option An option to request of the font. Valid options are: 126 | # -ascent -descent 127 | # -family -fixed 128 | # -font -fontBold 129 | # -fontItalic -linespace 130 | # -overstrike -size 131 | # -slant -underline 132 | # -weight -width 133 | # 134 | # Results: 135 | # Data about the font or empty string if no data exists. 136 | 137 | proc font::get {option} { 138 | variable metrics 139 | 140 | if {[info exists metrics($option)]} { 141 | return $metrics($option) 142 | } else { 143 | return {} 144 | } 145 | } 146 | 147 | 148 | 149 | 150 | -------------------------------------------------------------------------------- /src/tcl/lib/tcldebugger/image.tcl: -------------------------------------------------------------------------------- 1 | # image.tcl -- 2 | # 3 | # This file is loaded by startup.tcl to populate the image::image 4 | # array with platform dependent pre-loaded image types to be used 5 | # throughout the gui. 6 | # 7 | # Copyright (c) 1998-2000 Ajuba Solutions 8 | # Copyright (c) 2017 Forward Folio LLC 9 | # See the file "license.terms" for information on usage and redistribution of this file. 10 | # 11 | 12 | namespace eval image { 13 | variable image 14 | 15 | # Unix images are of the "photo" type. We store the photo data in 16 | # base64 format (converted from gif format) to aid packaging by 17 | # eliminating binary files. 18 | 19 | 20 | set image(break_disable) [image create photo \ 21 | -file $::debugger::libdir/images/break_d.gif] 22 | set image(break_enable) [image create photo \ 23 | -file $::debugger::libdir/images/break_e.gif] 24 | set image(var_disable) [image create photo \ 25 | -file $::debugger::libdir/images/var_d.gif] 26 | set image(var_enable) [image create photo \ 27 | -file $::debugger::libdir/images/var_e.gif] 28 | set image(comboArrow) [image create photo \ 29 | -file $::debugger::libdir/images/combo_arrow.gif] 30 | set image(current) [image create photo \ 31 | -file $::debugger::libdir/images/current.gif] 32 | set image(current_disable) [image create photo \ 33 | -file $::debugger::libdir/images/current_d.gif] 34 | set image(current_enable) [image create photo \ 35 | -file $::debugger::libdir/images/current_e.gif] 36 | set image(current_var) [image create photo \ 37 | -file $::debugger::libdir/images/current_v.gif] 38 | set image(run_disable) [image create photo \ 39 | -file $::debugger::libdir/images/go_d.gif] 40 | set image(run) [image create photo \ 41 | -file $::debugger::libdir/images/go.gif] 42 | set image(kill_disable) [image create photo \ 43 | -file $::debugger::libdir/images/kill_d.gif] 44 | set image(kill) [image create photo \ 45 | -file $::debugger::libdir/images/kill.gif] 46 | set image(restart_disable) [image create photo \ 47 | -file $::debugger::libdir/images/restart_d.gif] 48 | set image(restart) [image create photo \ 49 | -file $::debugger::libdir/images/restart.gif] 50 | set image(refreshFile_disable) [image create photo \ 51 | -file $::debugger::libdir/images/refresh_d.gif] 52 | set image(refreshFile) [image create photo \ 53 | -file $::debugger::libdir/images/refresh.gif] 54 | set image(into_disable) [image create photo \ 55 | -file $::debugger::libdir/images/stepin_d.gif] 56 | set image(into) [image create photo \ 57 | -file $::debugger::libdir/images/stepin.gif] 58 | set image(out_disable) [image create photo \ 59 | -file $::debugger::libdir/images/stepout_d.gif] 60 | set image(out) [image create photo \ 61 | -file $::debugger::libdir/images/stepout.gif] 62 | set image(over_disable) [image create photo \ 63 | -file $::debugger::libdir/images/stepover_d.gif] 64 | set image(over) [image create photo \ 65 | -file $::debugger::libdir/images/stepover.gif] 66 | set image(stop_disable) [image create photo \ 67 | -file $::debugger::libdir/images/stop_d.gif] 68 | set image(stop) [image create photo \ 69 | -file $::debugger::libdir/images/stop.gif] 70 | set image(history_disable) [image create photo \ 71 | -file $::debugger::libdir/images/history_disable.gif] 72 | set image(history_enable) [image create photo \ 73 | -file $::debugger::libdir/images/history_enable.gif] 74 | set image(history) [image create photo \ 75 | -file $::debugger::libdir/images/history.gif] 76 | set image(to_disable) [image create photo \ 77 | -file $::debugger::libdir/images/stepto_d.gif] 78 | set image(to) [image create photo \ 79 | -file $::debugger::libdir/images/stepto.gif] 80 | set image(cmdresult) [image create photo \ 81 | -file $::debugger::libdir/images/stepresult.gif] 82 | set image(cmdresult_disable) [image create photo \ 83 | -file $::debugger::libdir/images/stepresult_d.gif] 84 | 85 | set image(win_break) [image create photo \ 86 | -file $::debugger::libdir/images/win_break.gif] 87 | set image(win_eval) [image create photo \ 88 | -file $::debugger::libdir/images/win_eval.gif] 89 | set image(win_proc) [image create photo \ 90 | -file $::debugger::libdir/images/win_proc.gif] 91 | set image(win_watch) [image create photo \ 92 | -file $::debugger::libdir/images/win_watch.gif] 93 | set image(win_cover) [image create photo \ 94 | -file $::debugger::libdir/images/win_cover.gif] 95 | 96 | } 97 | -------------------------------------------------------------------------------- /src/tcl/lib/tcldebugger/initdebug.tcl: -------------------------------------------------------------------------------- 1 | # initdebug.tcl -- 2 | # 3 | # This file contains the public routines used to start debugging user 4 | # code in a remote application. 5 | # 6 | # Copyright (c) 1998-2000 Ajuba Solutions 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | 12 | # 13 | # This file comprises the public interface to the TclPro Debugger for use 14 | # by applications that are not launched directly from the debugger. The 15 | # public interface consists of the two commands "debugger_init" and 16 | # "debugger_eval". A typical application will source this file then invoke 17 | # "debugger_init" to initiate the connection to the debugger. Once 18 | # connected, the application can use the "debugger_eval" command to 19 | # evaluate scripts that the debugger will be able to step through. 20 | # Additionally, various other Tcl commands including "source" and "proc" 21 | # will automatically instrument code. Any blocks of code (e.g. procedure 22 | # bodies) that existed before "debugger_init" was invoked will execute 23 | # without any instrumentation. 24 | # 25 | 26 | # Avoid redefining these functions in case this file is sourced multiple 27 | # times. This ensures that we only connect to one debugger at a time. 28 | 29 | if {[info commands debugger_init] == ""} { 30 | 31 | # debugger_init -- 32 | # 33 | # This function initiates a connection to the TclPro Debugger. Files 34 | # that are sourced and procedures that are defined after this 35 | # function completes will be instrumented by the debugger. 36 | # 37 | # Arguments: 38 | # host Name of the host running the debugger. 39 | # port TCP port that the debugger is using. 40 | # 41 | # Results: 42 | # Returns 1 on success and 0 on failure. 43 | 44 | 45 | proc debugger_init {{host 127.0.0.1} {port 2576}} { 46 | global tcl_version 47 | 48 | if {[catch {set socket [socket $host $port]}] != 0} { 49 | return 0 50 | } 51 | fconfigure $socket -blocking 1 -translation binary 52 | 53 | # On 8.1 and later versions we should ensure the socket is not doing 54 | # any encoding translations. 55 | 56 | if {$tcl_version >= 8.1} { 57 | fconfigure $socket -encoding utf-8 58 | } 59 | 60 | # Send the loader and tcl library version 61 | 62 | set msg [list HELLO 1.0 $tcl_version] 63 | puts $socket [string length $msg] 64 | puts -nonewline $socket $msg 65 | flush $socket 66 | 67 | # Get the rest of the nub library and evaluate it in the current scope. 68 | # Note that the nub code assumes there will be a "socket" variable that 69 | # contains the debugger socket channel. 70 | 71 | if {[gets $socket bytes] == -1} { 72 | close $socket 73 | return 0 74 | } 75 | set msg [read $socket $bytes] 76 | eval [lindex $msg 1] 77 | return 1 78 | } 79 | 80 | # debugger_eval -- 81 | # 82 | # Instrument and evaluate a script. This routine is a trivial 83 | # implementation that is replaced when the nub is downloaded. 84 | # 85 | # Arguments: 86 | # args One or more arguments, the last of which must 87 | # be the script to evaluate. 88 | # 89 | # Results: 90 | # Returns the result of evaluating the script. 91 | 92 | proc debugger_eval {args} { 93 | global errorInfo errorCode 94 | set length [llength $args] 95 | if {$length < 1} { 96 | error "wrong # args: should be \"debugger_eval ?options? script\"" 97 | } 98 | set code [catch {uplevel 1 [lindex $args [expr {$length - 1}]]} result] 99 | return -code $code -errorcode $errorCode -errorinfo $errorInfo $result 100 | } 101 | 102 | # debugger_break -- 103 | # 104 | # This command may be inserted in user code to cause a break 105 | # to occur at the location of this command. If the application 106 | # is not connected to the debugger this command is a no-op. 107 | # 108 | # Arguments: 109 | # str (Optional) String that displays in debugger. 110 | # 111 | # Results: 112 | # None. Will send break message to debugger. 113 | 114 | proc debugger_break {{str ""}} { 115 | return 116 | } 117 | 118 | # debugger_attached -- 119 | # 120 | # This command may be used to detect if the debugger is 121 | # currently attached to the interpreter. 122 | # 123 | # Arguments: 124 | # None. 125 | # 126 | # Results: 127 | # Returns 1 if the debugger is currently attached. 128 | 129 | proc debugger_attached {} { 130 | return 0 131 | } 132 | 133 | # debugger_setCatchFlag -- 134 | # 135 | # Set the catch flag to indicate if errors should be caught by the 136 | # debugger. This flag is normally set to 0 by the "catch" command. 137 | # This command can be used to reset the flag to allow errors to be 138 | # reported by the debugger even if they would normally be masked by a 139 | # enclosing catch command. Note that the catch flag can be overridden by 140 | # the errorAction flag controlled by the user's project settings. 141 | # 142 | # Arguments: 143 | # flag The new value of the flag. 1 indicates thtat errors should 144 | # be caught by the debugger. 0 indicates that the debugger 145 | # should allow errors to propagate. 146 | # 147 | # Results: 148 | # Returns the previous value of the catch flag. 149 | # 150 | # Side effects: 151 | # None. 152 | 153 | proc debugger_setCatchFlag {flag} { 154 | return 1 155 | } 156 | 157 | 158 | } 159 | -------------------------------------------------------------------------------- /src/tcl/lib/tcldebugger/inspectorWin.tcl: -------------------------------------------------------------------------------- 1 | # inspectorWin.tcl -- 2 | # 3 | # This file implements the Inspector Window. 4 | # 5 | # Copyright (c) 1998-2000 Ajuba Solutions 6 | # Copyright (c) 2017 Forward Folio LLC 7 | # See the file "license.terms" for information on usage and redistribution of this file. 8 | # 9 | 10 | namespace eval inspector { 11 | variable entVar {} 12 | variable nameVar {} 13 | variable levelVar {} 14 | variable viewVar {} 15 | 16 | variable varText 17 | variable choiceBox 18 | 19 | variable levelCache {} 20 | variable nameCache {} 21 | variable valueCache {} 22 | variable viewCache {} 23 | 24 | variable dontLoop 0 25 | 26 | variable showResult 0 27 | } 28 | 29 | # inspector::showVariable -- 30 | # 31 | # Popup an Inspector window to display info on the selected 32 | # variable. 33 | # 34 | # Arguments: 35 | # name The variable name to show. 36 | # level The stack level containing the variable. 37 | # 38 | # Results: 39 | # None. 40 | 41 | proc inspector::showVariable {name level} { 42 | variable showResult 43 | variable entVar 44 | variable nameVar 45 | variable levelVar 46 | 47 | if {[gui::getCurrentState] != "stopped"} { 48 | return 49 | } 50 | 51 | # If the window already exists, show it, otherwise 52 | # create it from scratch. 53 | 54 | if {[info command $gui::gui(dataDbgWin)] != $gui::gui(dataDbgWin)} { 55 | inspector::createWindow 56 | } 57 | 58 | set showResult 0 59 | set entVar [code::mangle $name] 60 | set nameVar $entVar 61 | set levelVar $level 62 | inspector::updateWindow 1 63 | 64 | wm deiconify $gui::gui(dataDbgWin) 65 | focus $gui::gui(dataDbgWin) 66 | return $gui::gui(dataDbgWin) 67 | } 68 | 69 | # inspector::updateVarFromEntry -- 70 | # 71 | # Update the Data Display to show the variable named in the 72 | # entry widget. 73 | # 74 | # Arguments: 75 | # None. 76 | # 77 | # Results: 78 | # None. 79 | 80 | proc inspector::updateVarFromEntry {} { 81 | variable nameVar 82 | variable entVar 83 | variable levelVar 84 | variable showResult 85 | 86 | set showResult 0 87 | set entVar [code::mangle $entVar] 88 | set nameVar $entVar 89 | set levelVar [gui::getCurrentLevel] 90 | 91 | inspector::updateWindow 1 92 | return 93 | } 94 | 95 | # inspector::showResult -- 96 | # 97 | # Popup an Inspector window to display info on the current 98 | # interpreter result value. 99 | # 100 | # Arguments: 101 | # None. 102 | # 103 | # Results: 104 | # None. 105 | 106 | proc inspector::showResult {} { 107 | variable showResult 108 | variable entVar 109 | variable nameVar 110 | variable levelVar 111 | 112 | if {[gui::getCurrentState] != "stopped"} { 113 | return 114 | } 115 | 116 | # If the window already exists, show it, otherwise 117 | # create it from scratch. 118 | 119 | if {[info command $gui::gui(dataDbgWin)] != $gui::gui(dataDbgWin)} { 120 | inspector::createWindow 121 | } 122 | 123 | # Set the inspector into showResult mode and refesh the window. 124 | 125 | set showResult 1 126 | set entVar {} 127 | set nameVar "" 128 | set levelVar [dbg::getLevel] 129 | inspector::updateWindow 1 130 | 131 | wm deiconify $gui::gui(dataDbgWin) 132 | focus $gui::gui(dataDbgWin) 133 | return $gui::gui(dataDbgWin) 134 | } 135 | 136 | # inspector::createWindow -- 137 | # 138 | # Create an Inspector window that displays info on 139 | # a particular variable and allows the variables 140 | # value to be changed and variable breakpoints to 141 | # be set and unset. 142 | # 143 | # Arguments: 144 | # None. 145 | # 146 | # Results: 147 | # None. 148 | 149 | proc inspector::createWindow {} { 150 | variable varText 151 | variable choiceBox 152 | 153 | set top [toplevel $gui::gui(dataDbgWin)] 154 | ::guiUtil::positionWindow $top 400x250 155 | wm minsize $top 100 100 156 | wm title $top "Data Display" 157 | wm transient $top $gui::gui(mainDbgWin) 158 | 159 | set relief groove 160 | set pad 6 161 | set bd 2 162 | 163 | # Create the info frame that displays the level and name. 164 | 165 | set mainFrm [frame $top.mainFrm -bd $bd -relief raised] 166 | 167 | # Create the entry for adding new Watch variables. 168 | 169 | set inspectFrm [frame $mainFrm.inspectFrm] 170 | set inspectLbl [label $inspectFrm.inspectLbl -anchor w -text "Variable:"] 171 | set inspectEnt [entry $inspectFrm.inspectEnt \ 172 | -textvariable inspector::entVar] 173 | set inspectBut [button $inspectFrm.inspectBut -text "Display" -width 8 \ 174 | -command inspector::updateVarFromEntry] 175 | set closeBut [button $inspectFrm.closeBut -text "Close" -width 8 \ 176 | -command "destroy $gui::gui(dataDbgWin)"] 177 | 178 | pack $closeBut -side right -padx $pad 179 | pack $inspectBut -side right 180 | pack $inspectLbl -side left 181 | pack $inspectEnt -side left -padx $pad -fill x -expand true 182 | 183 | set dataFrm [frame $mainFrm.infoFrm -bd $bd -relief groove] 184 | set infoFrm [frame $dataFrm.infoFrm] 185 | set nameTitleLbl [label $infoFrm.nameTitleLbl -text "Variable Name:" ] 186 | set nameLbl [label $infoFrm.nameLbl -justify left \ 187 | -textvariable inspector::nameVar] 188 | set levelTitleLbl [label $infoFrm.levelTitleLbl -text "Stack Level:" ] 189 | set levelLbl [label $infoFrm.levelLbl -justify left \ 190 | -textvariable inspector::levelVar] 191 | pack $nameTitleLbl -pady 3 -side left 192 | pack $nameLbl -padx 3 -pady 3 -side left 193 | pack $levelTitleLbl -pady 3 -side left 194 | pack $levelLbl -padx 3 -pady 3 -side left 195 | 196 | # Place a separating line between the var info and the 197 | # value of the var. 198 | 199 | set sep1Frm [frame $dataFrm.sep1 -bd $bd -relief $relief -height $bd] 200 | 201 | set choiceFrm [frame $dataFrm.choiceFrm] 202 | set choiceLbl [label $choiceFrm.choiceLbl -text "View As:" ] 203 | set choiceBox [guiUtil::ComboBox $choiceFrm.choiceCombo -listheight 4 \ 204 | -textvariable inspector::viewVar -strict 1 \ 205 | -command {inspector::updateWindow 0}] 206 | 207 | foreach choice {"Array" "List" "Raw Data" "Line Wrap"} { 208 | $choiceBox add $choice 209 | } 210 | set inspector::viewVar "Line Wrap" 211 | pack $choiceLbl -pady 3 -side left 212 | pack $choiceBox -padx 3 -pady 3 -side left 213 | 214 | # Place a separating line between the var info and the 215 | # value of the var. 216 | 217 | set sep2Frm [frame $dataFrm.sep2 -bd $bd -relief $relief -height $bd] 218 | 219 | # Create an empty frame that will be populated in the updateWindow 220 | # routine. 221 | 222 | set varFrm [frame $dataFrm.varFrm] 223 | set varText [text $varFrm.varText -width 1 -height 2 \ 224 | -yscroll [list $varFrm.yscroll set] \ 225 | -xscroll [list $varFrm.xscroll set] ] 226 | set yscroll [scrollbar $varFrm.yscroll -command [list $varText yview]] 227 | set xscroll [scrollbar $varFrm.xscroll -command [list $varText xview] \ 228 | -orient horizontal] 229 | grid $varText -row 0 -column 0 -sticky nswe 230 | grid $yscroll -row 0 -column 1 -sticky ns 231 | grid $xscroll -row 1 -column 0 -sticky we 232 | grid columnconfigure $varFrm 0 -weight 1 233 | grid rowconfigure $varFrm 0 -weight 1 234 | 235 | pack $infoFrm -padx $pad -pady $pad -fill x 236 | pack $sep1Frm -padx $pad -fill x 237 | pack $choiceFrm -padx $pad -pady $pad -fill x 238 | pack $sep2Frm -padx $pad -fill x 239 | pack $varFrm -padx $pad -pady $pad -expand true -fill both 240 | 241 | pack $dataFrm -padx $pad -pady $pad -fill both -expand true -side bottom 242 | pack $inspectFrm -padx $pad -pady $pad -fill x -side bottom 243 | pack $mainFrm -padx $pad -pady $pad -fill both -expand true -side bottom 244 | 245 | gui::setDbgTextBindings $varText 246 | bind::addBindTags $varText [list noEdit dataDbgWin] 247 | bind::addBindTags $inspectEnt dataDbgWin 248 | bind::addBindTags $inspectBut dataDbgWin 249 | 250 | bind::commonBindings dataDbgWin [list $inspectEnt $inspectBut $varText] 251 | 252 | bind $inspectEnt { 253 | inspector::updateVarFromEntry 254 | break 255 | } 256 | } 257 | 258 | # inspector::updateWindow -- 259 | # 260 | # Update the display of the Inspector. A Tcl variable 261 | # may be aliased with different names at different 262 | # levels, so update the name and level as well as the 263 | # value. 264 | # 265 | # Arguments: 266 | # name The variable name. 267 | # valu The variable valu. If the variable is an 268 | # array, this is an ordered list of array 269 | # index and array value. 270 | # type Variable type ('a' == array, 's' == scalar) 271 | # level The stack level of the variable. 272 | # 273 | # Results: 274 | # None. 275 | 276 | proc inspector::updateWindow {{setChoice 0}} { 277 | variable nameVar 278 | variable levelVar 279 | variable showResult 280 | variable varText 281 | variable choiceBox 282 | variable levelCache 283 | variable nameCache 284 | variable valueCache 285 | variable viewCache 286 | 287 | if {![winfo exists $gui::gui(dataDbgWin)]} { 288 | return 289 | } 290 | if {[gui::getCurrentState] != "stopped"} { 291 | return 292 | } 293 | 294 | if {$showResult} { 295 | # Fetch the interpreter result and update the level 296 | set type s 297 | set value [lindex [dbg::getResult -1] 1] 298 | } else { 299 | # Fetch the named variable 300 | if {[catch { 301 | set varInfo [lindex [dbg::getVar $levelVar -1 [list $nameVar]] 0] 302 | }]} { 303 | set varInfo {} 304 | } 305 | if {$varInfo == {}} { 306 | set type s 307 | set value "" 308 | } else { 309 | set type [lindex $varInfo 1] 310 | set value [lindex $varInfo 2] 311 | } 312 | } 313 | set data {} 314 | if {$type == "a"} { 315 | foreach v $value { 316 | lappend data [code::binaryClean $v] 317 | } 318 | } else { 319 | set data [code::binaryClean $value] 320 | } 321 | 322 | if {$setChoice} { 323 | if {$type == "a"} { 324 | set inspector::viewVar "Array" 325 | } else { 326 | set inspector::viewVar "Line Wrap" 327 | } 328 | } 329 | set view [$choiceBox get] 330 | 331 | if {($nameVar == $nameCache) && ($levelVar == $levelCache) \ 332 | && ($value == $valueCache) && ($view == $viewCache)} { 333 | if {[$varText get 1.0 1.1] != ""} { 334 | return 335 | } 336 | } 337 | 338 | $varText delete 0.0 end 339 | switch $view { 340 | "Raw Data" { 341 | $varText configure -wrap none -tabs {} 342 | $varText insert 0.0 $value 343 | } 344 | "Line Wrap" { 345 | $varText configure -wrap word -tabs {} 346 | $varText insert 0.0 $value 347 | } 348 | "List" { 349 | if {[catch {llength $value}]} { 350 | # If we get an error in llength then we can't 351 | # display as a list. 352 | 353 | $varText insert end "" 354 | } else { 355 | $varText configure -wrap none -tabs {} 356 | foreach index $value { 357 | $varText insert end "$index\n" 358 | } 359 | } 360 | } 361 | "Array" { 362 | if {[catch {set len [llength $value]}] || ($len % 2)} { 363 | # If we get an error in llength or we don't have 364 | # an even number of elements then we can't 365 | # display as aa array. 366 | 367 | $varText insert end "" 368 | } else { 369 | $varText configure -wrap none 370 | 371 | set line 1 372 | set max 0 373 | set maxLine 1 374 | foreach {entry index} $value { 375 | $varText insert end "$entry \n" 376 | set len [string length $entry] 377 | if {$len > $max} { 378 | set max $len 379 | set maxLine $line 380 | } 381 | incr line 382 | } 383 | 384 | $varText see $maxLine.0 385 | set maxWidth [lindex [$varText dlineinfo $maxLine.0] 2] 386 | $varText delete 0.0 end 387 | $varText configure -tabs $maxWidth 388 | 389 | array set temp $value 390 | 391 | foreach entry [lsort -dictionary [array names temp]] { 392 | $varText insert end "$entry\t= $temp($entry)\n" 393 | } 394 | } 395 | } 396 | default { 397 | error "Unexpected view type \"$view\" in inspector::updateWindow" 398 | } 399 | } 400 | 401 | set nameCache $nameVar 402 | set levelCache $levelVar 403 | set valueCache $value 404 | set viewCache $view 405 | return 406 | } 407 | -------------------------------------------------------------------------------- /src/tcl/lib/tcldebugger/location.tcl: -------------------------------------------------------------------------------- 1 | # location.tcl -- 2 | # 3 | # This file contains functions that maintain the 4 | # location data structure. 5 | # 6 | # Copyright (c) 1998-2000 Ajuba Solutions 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | package provide loc 1.0 12 | namespace eval loc { 13 | # location data type -- 14 | # 15 | # A location encapsulates the state associated with a range of 16 | # bytes within a block of code. Each location is represented by 17 | # a Tcl list of the form {block line range}. The block is 18 | # the block identifier for the code that contains the range. 19 | # The line is the line number of the first byte in the range. 20 | # The range indicates the extent of the location within the 21 | # block in a form suitable for use with the parser. 22 | 23 | } 24 | # end namespace loc 25 | 26 | 27 | # loc::getBlock -- 28 | # 29 | # Returns the block that contains the given location. 30 | # If no such location exists, an error is generated. 31 | # 32 | # Arguments: 33 | # location The code location whose block is returned. 34 | # 35 | # Results: 36 | # Returns the block that contains the given location. 37 | 38 | proc loc::getBlock {location} { 39 | return [lindex $location 0] 40 | } 41 | 42 | 43 | # loc::getLine -- 44 | # 45 | # Returns the line number for the start of the location as an 46 | # offset from the beginning of the block. If no such location 47 | # exists, an error is generated. 48 | # 49 | # Arguments: 50 | # location The code location whose line number is returned. 51 | # 52 | # Results: 53 | # Returns the line number for the start of the location as an 54 | # offset from the beginning of the block. 55 | 56 | proc loc::getLine {location} { 57 | return [lindex $location 1] 58 | } 59 | 60 | # loc::getRange -- 61 | # 62 | # Returns the range for the given location in a form suitable 63 | # for use with the parser interface. If no such location 64 | # exists, an error is generated. 65 | # 66 | # Arguments: 67 | # location The code location whose range is returned. 68 | # 69 | # Results: 70 | # Returns the range for the given location in a form suitable 71 | # for use with the parser interface. 72 | 73 | proc loc::getRange {location} { 74 | variable locArray 75 | 76 | return [lindex $location 2] 77 | } 78 | 79 | # loc::makeLocation -- 80 | # 81 | # Creates a new location based on the block, range, and line values. 82 | # If the block is invalid, an error is generated. Either the range 83 | # or line must be non-empty, otherwise an error is generated. 84 | # 85 | # Arguments: 86 | # block The block containing the location to be created. 87 | # line The line number of the beginning of the location. 88 | # range Optional. A pair of the location's start and length 89 | # byte values. 90 | # 91 | # Results: 92 | # Returns a unique location identifier. 93 | 94 | proc loc::makeLocation {block line {range {}}} { 95 | return [list $block $line $range] 96 | } 97 | 98 | # loc::match -- 99 | # 100 | # Compare two locations to see if the second location is a match 101 | # for the first location. If the first location has no range, then 102 | # it will match all locations with the same line number. If the 103 | # first location has no line number, then it will match all locations 104 | # with the same block. Otherwise it will only match locations that 105 | # have exactly the same block, line and range. 106 | # 107 | # Arguments: 108 | # pattern The location pattern. 109 | # location The location to test. 110 | # 111 | # Results: 112 | # Returns 1 if the location matches the pattern. 113 | 114 | proc loc::match {pattern location} { 115 | # Check for null line. 116 | if {[lindex $pattern 1] == ""} { 117 | return [expr {[string compare [lindex $pattern 0] \ 118 | [lindex $location 0]] == 0}] 119 | } 120 | # Check for null range. 121 | if {[lindex $pattern 2] == ""} { 122 | return [expr {[string compare [lrange $pattern 0 1] \ 123 | [lrange $location 0 1]] == 0}] 124 | } 125 | # Compare the full location. 126 | return [expr {[string compare $pattern $location] == 0}] 127 | } 128 | 129 | -------------------------------------------------------------------------------- /src/tcl/lib/tcldebugger/oratcl.pdx: -------------------------------------------------------------------------------- 1 | # oratcl.pdx -- 2 | # 3 | # This file implements the TclPro Debugger extension for OraTcl. 4 | # 5 | # Copyright (c) 1998-2000 Ajuba Solutions 6 | # Copyright (c) 2017 Forward Folio LLC 7 | # See the file "license.terms" for information on usage and redistribution of this file. 8 | # 9 | # RCS: @(#) $Id: oratcl.pdx,v 1.3 2000/05/30 22:54:42 hershey Exp $ 10 | 11 | # Register the Oratcl extension 12 | 13 | instrument::addExtension 2.0 {OraTcl} 14 | 15 | # Register handlers for each of the Oratcl commands 16 | 17 | instrument::addCommand orafetch {parseSimpleArgs 1 -1 {parseWord parseBody parseWord}} 18 | -------------------------------------------------------------------------------- /src/tcl/lib/tcldebugger/pkgIndex.tcl: -------------------------------------------------------------------------------- 1 | package ifneeded debugger 2.0 [list source [file join $dir debugger.tcl]] -------------------------------------------------------------------------------- /src/tcl/lib/tcldebugger/portWin.tcl: -------------------------------------------------------------------------------- 1 | # portWin.tcl -- 2 | # 3 | # This file defines the APIs needed to display the bad port dialog 4 | # when a user enters an invalid or taken port. 5 | # 6 | # Copyright (c) 1998-2000 Ajuba Solutions 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | namespace eval portWin { 12 | # Widgets that are used througout this module for updating 13 | # messages and for setting and retrieving port values. 14 | 15 | variable msgLbl 16 | variable portEnt 17 | 18 | # Vwait variable used to indicate when a valid port has been 19 | # entered. 20 | 21 | variable newPortVar 22 | } 23 | 24 | # portWin::showWindow -- 25 | # 26 | # Show the window. If it does not exist, create it. If it does 27 | # exist, bring it to focus. 28 | # 29 | # Arguments: 30 | # port The invalid port. 31 | # 32 | # Results: 33 | # The next OK port to use. 34 | 35 | proc portWin::showWindow {port} { 36 | if {[info command $gui::gui(errorPortWin)] == $gui::gui(errorPortWin)} { 37 | wm deiconify $gui::gui(errorPortWin) 38 | } else { 39 | portWin::CreateWindow 40 | } 41 | 42 | portWin::UpdateWindow $port 43 | focus -force $portWin::portEnt 44 | grab $gui::gui(errorPortWin) 45 | 46 | vwait portWin::newPortVar 47 | return $portWin::newPortVar 48 | } 49 | 50 | # portWin::CreateWindow -- 51 | # 52 | # Create the window from scratch. It is assumed that the window 53 | # currently does not exist. 54 | # 55 | # Arguments: 56 | # None. 57 | # 58 | # Results: 59 | # None. 60 | 61 | proc portWin::CreateWindow {} { 62 | variable msgLbl 63 | variable portEnt 64 | 65 | set bd 2 66 | set pad 6 67 | set pad2 3 68 | set width 350 69 | set height 50 70 | 71 | set top [toplevel $gui::gui(errorPortWin)] 72 | wm title $top "Error Opening Port" 73 | wm minsize $top 100 100 74 | wm transient $top $gui::gui(mainDbgWin) 75 | 76 | # Center window on the screen. 77 | 78 | set w [winfo screenwidth .] 79 | set h [winfo screenheight .] 80 | wm geometry $gui::gui(errorPortWin) \ 81 | +[expr {($w/2) - ($width/2)}]+[expr {($h/2) - ($height/2)}] 82 | 83 | set mainFrm [frame $top.mainFrm -bd $bd -relief raised] 84 | set imageLbl [label $mainFrm.imageLbl -bitmap error] 85 | set msgLbl [label $mainFrm.msgLbl -wraplength $width -justify left] 86 | 87 | set portFrm [frame $mainFrm.portFrm] 88 | set portLabel [label $portFrm.portLabel -text "Next available port:"] 89 | set portEnt [entry $portFrm.portEnt -width 6 -exportselection 0] 90 | 91 | set butFrm [frame $top.butFrm] 92 | set okBut [button $butFrm.okBut -text "OK" -default active \ 93 | -command {portWin::ApplyWindow} -width 12] 94 | set cancelBut [button $butFrm.cancelBut -text "Cancel" -default normal \ 95 | -command [list destroy $top] -width 12] 96 | 97 | pack $portEnt -side right 98 | pack $portLabel -side right 99 | 100 | grid $imageLbl -row 0 -column 0 -sticky w -padx $pad -pady $pad 101 | grid $msgLbl -row 0 -column 1 -sticky w -padx $pad -pady $pad 102 | grid $portFrm -row 2 -column 1 -sticky w -padx $pad -pady $pad 103 | grid columnconfigure $mainFrm 1 -weight 1 104 | grid rowconfigure $mainFrm 1 -weight 1 105 | 106 | pack $cancelBut -side right -padx $pad 107 | pack $okBut -side right -padx $pad 108 | pack $butFrm -side bottom -fill x -pady $pad2 109 | pack $mainFrm -side bottom -fill both -expand true -padx $pad -pady $pad 110 | 111 | bind $portEnt "$okBut invoke; break" 112 | bind $okBut {%W invoke; break} 113 | bind $top "$okBut invoke; break" 114 | bind $top "$cancelBut invoke; break" 115 | 116 | return 117 | } 118 | 119 | # portWin::UpdateWindow -- 120 | # 121 | # Show the error message and prompt the user for a new port. 122 | # 123 | # Arguments: 124 | # port The invalid port. 125 | # 126 | # Results: 127 | # None. 128 | 129 | proc portWin::UpdateWindow {port} { 130 | variable msgLbl 131 | variable portEnt 132 | 133 | # Insert the message stating that the port was taken or is invalid. 134 | 135 | append msg "Port \"$port\" is invalid or in use. " 136 | append msg "Please specify another port to use for this project. " 137 | append msg "This will automatically modify your project settings." 138 | $msgLbl configure -text $msg 139 | 140 | # Find the next open port. Loop while the port is in use. 141 | # Make sure the port entered is a valid integer. If it is not, use 142 | # the initial factory default setting as a starting point for locating 143 | # the next available port. 144 | 145 | if {[catch {incr port}]} { 146 | set port [pref::prefGet portRemote ProjectFactory] 147 | } 148 | while {![portWin::isPortValid $port]} { 149 | incr port 150 | } 151 | 152 | # Insert the new suggested port to be used. 153 | 154 | $portEnt delete 0 end 155 | $portEnt insert 0 $port 156 | $portEnt selection range 0 end 157 | 158 | return 159 | } 160 | 161 | # portWin::ApplyWindow -- 162 | # 163 | # Verify the new port is valid. If the nerw port is valid then 164 | # destroy the window and set the vwait var to the value of the 165 | # port. Otherwise beep and update the error message. 166 | # 167 | # Arguments: 168 | # None. 169 | # 170 | # Results: 171 | # None. 172 | 173 | proc portWin::ApplyWindow {} { 174 | variable portEnt 175 | 176 | set port [$portEnt get] 177 | if {[portWin::isPortValid $port]} { 178 | grab release $gui::gui(errorPortWin) 179 | destroy $gui::gui(errorPortWin) 180 | set ::portWin::newPortVar $port 181 | } else { 182 | bell 183 | portWin::UpdateWindow $port 184 | } 185 | return 186 | } 187 | 188 | # portWin::isPortValid -- 189 | # 190 | # Test to see if the port is valid. 191 | # 192 | # Arguments: 193 | # port The port to test. 194 | # 195 | # Results: 196 | # Return a boolean, 1 means the port is OK. 197 | 198 | proc portWin::isPortValid {port} { 199 | global errorCode 200 | 201 | # First test to see that the port is a valid integer. 202 | 203 | if {[catch {incr port 0}]} { 204 | return 0 205 | } 206 | 207 | # If the errorCode is not EADDRINUSE nor EACCES then an error occured 208 | # that was not a taken port. Make sure to close the port when one 209 | # is found, so the correct routine can be called to re-open 210 | # the same port. 211 | 212 | if {([catch {set sock [socket -server dummy $port]}] != 0) \ 213 | && ([lsearch -exact \ 214 | [list "EADDRINUSE" "EACCES"] \ 215 | [lindex $errorCode 1]] != -1)} { 216 | return 0 217 | } 218 | close $sock 219 | return 1 220 | } 221 | 222 | -------------------------------------------------------------------------------- /src/tcl/lib/tcldebugger/result.tcl: -------------------------------------------------------------------------------- 1 | # result.tcl -- 2 | # 3 | # This file implements the command result window. 4 | # 5 | # Copyright (c) 1998-2000 Ajuba Solutions 6 | # Copyright (c) 2017 Forward Folio LLC 7 | # See the file "license.terms" for information on usage and redistribution of this file. 8 | # 9 | 10 | namespace eval result { 11 | variable text {} 12 | variable frame {} 13 | } 14 | 15 | # result::createWindow -- 16 | # 17 | # Create the window for displaying command results inside the specified 18 | # master. 19 | # 20 | # Arguments: 21 | # mainDbgWin The toplevel window for the main debugger. 22 | # 23 | # Results: 24 | # The handle to the frame that contains the result window. 25 | 26 | proc result::createWindow {mainDbgWin} { 27 | variable text 28 | variable frame 29 | 30 | set frame [frame $mainDbgWin.frame] 31 | set text [text $frame.text -width 1 -height 1 -bd 2 \ 32 | -relief sunken] 33 | grid $text -row 0 -column 1 -sticky we -pady 1 34 | grid columnconf $frame 1 -weight 1 35 | 36 | # Add a little extra space below the text widget so it looks right with the 37 | # status bar in place. 38 | 39 | grid rowconf $frame 1 -minsize 3 40 | bind $text { 41 | gui::formatText $result::text right 42 | } 43 | 44 | # Set the behavior so we get the standard truncation behavior 45 | gui::setDbgTextBindings $text 46 | 47 | # Add a double-click binding to take us to the data display window 48 | bind $text {inspector::showResult} 49 | 50 | return $frame 51 | } 52 | 53 | proc result::updateWindow {} { 54 | variable text 55 | if {[winfo exists $result::frame] \ 56 | && [winfo ismapped $result::frame]} { 57 | resetWindow 58 | 59 | set result [dbg::getResult [font::get -maxchars]] 60 | set code [lindex $result 0] 61 | 62 | set codes {OK ERROR RETURN BREAK CONTINUE} 63 | 64 | if {$code < [llength $codes]} { 65 | set code [lindex $codes $code] 66 | } 67 | set result [code::mangle [lindex $result 1]] 68 | 69 | $text insert 1.0 "Code: $code\tResult: $result" 70 | gui::formatText $text right 71 | } 72 | return 73 | } 74 | 75 | proc result::resetWindow {} { 76 | variable text 77 | 78 | gui::unsetFormatData $text 79 | $text delete 0.0 end 80 | return 81 | } 82 | -------------------------------------------------------------------------------- /src/tcl/lib/tcldebugger/sybtcl.pdx: -------------------------------------------------------------------------------- 1 | # sybtcl.pdx -- 2 | # 3 | # This file implements the TclPro Debugger extension for Sybtcl. 4 | # 5 | # Copyright (c) 1998-2000 Ajuba Solutions 6 | # Copyright (c) 2017 Forward Folio LLC 7 | # See the file "license.terms" for information on usage and redistribution of this file. 8 | # 9 | 10 | # Register the Sybtcl extension 11 | 12 | instrument::addExtension 2.0 {sybtcl} 13 | 14 | # Register handlers for each of the Sybtcl commands 15 | 16 | instrument::addCommand sybevent {parseSimpleArgs 1 2 { 17 | parseWord parseBody}} 18 | 19 | instrument::addCommand sybnext {parseSimpleArgs 1 -1 { 20 | parseWord parseBody parseWord}} 21 | -------------------------------------------------------------------------------- /src/tcl/lib/tcldebugger/tclCom.pdx: -------------------------------------------------------------------------------- 1 | # tclCom.pdx -- 2 | # 3 | # This file implements the TclPro Debugger extension for the Tcl 4 | # Com API. 5 | # 6 | # Copyright (c) 1998-2000 Ajuba Solutions 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | # Register the Tcl Com extension 12 | 13 | instrument::addExtension 2.0 {tclCom} 14 | 15 | # Register handlers for each of the XML Generation commands 16 | 17 | instrument::addCommand foreachitem {parseTail 3 { 18 | parseWord parseBody}} 19 | instrument::addCommand tclcom::foreachitem {parseTail 3 { 20 | parseWord parseBody}} 21 | -------------------------------------------------------------------------------- /src/tcl/lib/tcldebugger/tcltest.pdx: -------------------------------------------------------------------------------- 1 | # tcltest.pdx -- 2 | # 3 | # This file implements custom instrumenter extensions 4 | # for the tcltest package. 5 | # 6 | # Copyright (c) 1998-2000 Ajuba Solutions 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | # Register the tcltest extension 12 | 13 | instrument::addExtension 2.0 {parseTest} 14 | 15 | namespace eval parseTest { 16 | } 17 | 18 | # Register handlers for each of the tcltest commands 19 | 20 | instrument::addCommand test {parseTail 4 { 21 | parseWord parseBody parseWord}} 22 | instrument::addCommand tcltest::test {parseTail 4 { 23 | parseWord parseBody parseWord}} 24 | -------------------------------------------------------------------------------- /src/tcl/lib/tcldebugger/tests/all.tcl: -------------------------------------------------------------------------------- 1 | # all.tcl -- 2 | # 3 | # This file contains a top-level script to run all of the 4 | # tcldebugger tests. 5 | # 6 | # Copyright (c) 1998-2000 by Ajuba Solutions 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | if {[info exists ::tcltest::testSingleFile]} { 12 | if {!$::tcltest::testSingleFile} { 13 | set saveOutput $::tcltest::temporaryDirectory 14 | } 15 | } 16 | 17 | lappend auto_path [file join [file dirname [info script]] ..] 18 | package require protest 19 | catch {namespace import ::protest::*} 20 | 21 | if {[info exists saveOutput]} { 22 | set ::tcltest::temporaryDirectory $saveOutput 23 | } 24 | 25 | puts "Temporary files stored in $::tcltest::temporaryDirectory" 26 | set timeCmd {clock format [clock seconds]} 27 | puts stdout "Tests began at [eval $timeCmd]" 28 | 29 | if {$tcl_platform(platform) == "windows"} { 30 | ::protest::testAllFiles "" wish$::protest::currentVersion(Tk-short) 31 | } else { 32 | ::protest::testAllFiles "" wish$::protest::currentVersion(Tk) 33 | } 34 | 35 | set numFailures [llength $::tcltest::failFiles] 36 | 37 | puts stdout "\nTests ended at [eval $timeCmd]" 38 | ::tcltest::cleanupTests 1 39 | 40 | if {$numFailures > 0} { 41 | return -code error -errorcode $numFailures \ 42 | -errorinfo "Found $numFailures test file failures" 43 | } else { 44 | return 45 | } 46 | -------------------------------------------------------------------------------- /src/tcl/lib/tcldebugger/tests/block.test: -------------------------------------------------------------------------------- 1 | # This file contains tests for the block.tcl file. 2 | # 3 | # Copyright (c) 1998-2000 by Ajuba Solutions 4 | # Copyright (c) 2017 Forward Folio LLC 5 | # 6 | # See the file "license.terms" for information on usage and redistribution 7 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. 8 | # 9 | 10 | if {[string compare test [info procs test]] == 1} { 11 | lappend auto_path [file join [file dirname [info script]] ..] 12 | package require protest 13 | namespace import ::protest::* 14 | } 15 | 16 | catch {parse} parseMsg 17 | if {[regexp "invalid command" $parseMsg]} { 18 | package require parser 19 | } 20 | 21 | source [file join $::protest::sourceDirectory system.tcl] 22 | source [file join $::protest::sourceDirectory block.tcl] 23 | source [file join $::protest::sourceDirectory instrument.tcl] 24 | source [file join $::protest::sourceDirectory location.tcl] 25 | source [file join $::protest::sourceDirectory util.tcl] 26 | 27 | set pwd [pwd] 28 | cd $::tcltest::temporaryDirectory 29 | 30 | set contents "line 1\nline2\nline3\n" 31 | makeFile $contents dummy.tcl 32 | 33 | blk::release all 34 | 35 | test block-1.1 {blk::makeBlock, duplicates} { 36 | set b1 [blk::makeBlock dummy.tcl] 37 | set b2 [blk::makeBlock dummy.tcl] 38 | set result [list [string compare $b1 $b2] \ 39 | [lsort [array names blk::blk$b1]] \ 40 | [set blk::blk${b1}(file)] [set blk::blk${b1}(instrumented)] \ 41 | [set blk::blk${b1}(version)]] 42 | 43 | blk::release $b1 44 | set result 45 | } {0 {file instrumented lines version} dummy.tcl 0 0} 46 | test block-1.2 {blk::makeBlock, multiple} { 47 | set b1 [blk::makeBlock dummy.tcl] 48 | set b2 [blk::makeBlock dummy2.tcl] 49 | set result [list [expr [string compare $b1 $b2] == 0] \ 50 | [lsort [array names blk::blk$b1]] \ 51 | [set blk::blk${b1}(file)] [set blk::blk${b1}(instrumented)] \ 52 | [set blk::blk${b1}(version)] \ 53 | [lsort [array names blk::blk$b2]] \ 54 | [set blk::blk${b2}(file)] [set blk::blk${b2}(instrumented)] \ 55 | [set blk::blk${b2}(version)]] 56 | blk::release $b1 $b2 57 | set result 58 | } {0 {file instrumented lines version} dummy.tcl 0 0 {file instrumented lines version} dummy2.tcl 0 0} 59 | test block-1.3 {blk::makeBlock, id reuse} { 60 | set next [expr $blk::blockCounter + 1] 61 | set blk::blk$next 1 62 | set b1 [blk::makeBlock dummy.tcl] 63 | set result [expr $b1 == $next] 64 | blk::release $b1 65 | set result 66 | } 0 67 | test block-1.4 {blk::makeBlock, dynamic blocks} { 68 | set b1 [blk::makeBlock ""] 69 | set b2 [blk::makeBlock ""] 70 | set result [expr [string compare $b1 $b2] == 0] 71 | blk::release $b1 $b2 72 | set result 73 | } 0 74 | 75 | test block-2.1 {blk::release, single} { 76 | set b1 [blk::makeBlock ""] 77 | set result [info exists blk::blk$b1] 78 | blk::release $b1 79 | lappend result [info exists blk::blk$b1] 80 | } {1 0} 81 | test block-2.2 {blk::release, multiple} { 82 | set b1 [blk::makeBlock ""] 83 | set b2 [blk::makeBlock ""] 84 | set result [list [info exists blk::blk$b1] [info exists blk::blk$b2]] 85 | blk::release $b1 $b2 86 | lappend result [info exists blk::blk$b1] [info exists blk::blk$b2] 87 | } {1 1 0 0} 88 | test block-2.3 {blk::release, bad input} { 89 | list [info exists blk::blk1] [blk::release 1] 90 | } {0 {}} 91 | 92 | test block-4.1 {blk::exists} { 93 | blk::release 1 94 | blk::exists 1 95 | } 0 96 | test block-4.2 {blk::exists} { 97 | set b1 [blk::makeBlock foo] 98 | set result [blk::exists $b1] 99 | blk::release $b1 100 | set result 101 | } 1 102 | 103 | test block-3.1 {blk::getSource, instrumented} { 104 | set b1 [blk::makeBlock foo] 105 | blk::Instrument $b1 foobarbaz 106 | set result [blk::getSource $b1] 107 | blk::release $b1 108 | set result 109 | } foobarbaz 110 | test block-3.2 {blk::getSource, uninstrumented} { 111 | set b1 [blk::makeBlock dummy.tcl] 112 | set result [string compare [blk::getSource $b1] $contents] 113 | blk::release $b1 114 | set result 115 | } 0 116 | test block-3.3 {blk::getSource, partially constructed dynamic code} { 117 | set b1 [blk::makeBlock ""] 118 | set result [list [blk::getSource $b1]] 119 | blk::Instrument $b1 foobarbaz 120 | lappend result [blk::getSource $b1] 121 | blk::release $b1 122 | set result 123 | } {{} foobarbaz} 124 | test block-3.4 {blk::getSource, multiple reads from file} { 125 | set b1 [blk::makeBlock dummy.tcl] 126 | set result [string compare [blk::getSource $b1] $contents] 127 | lappend result [blk::getVersion $b1] 128 | lappend result [string compare [blk::getSource $b1] $contents] 129 | lappend result [blk::getVersion $b1] 130 | blk::release $b1 131 | set result 132 | } {0 1 0 2} 133 | 134 | test block-4.1 {blk::getFile} { 135 | set b1 [blk::makeBlock foobar] 136 | set result [blk::getFile $b1] 137 | blk::release $b1 138 | set result 139 | } foobar 140 | test block-4.2 {blk::getFile} { 141 | set b1 [blk::makeBlock ""] 142 | set result [blk::getFile $b1] 143 | blk::release $b1 144 | set result 145 | } {} 146 | 147 | set b1 [blk::makeBlock foobar] 148 | test block-5.1 {blk::Instrument} { 149 | blk::Instrument $b1 blah 150 | } "DbgNub_Do 0 {$b1 1 {0 4}} blah" 151 | blk::release $b1 152 | 153 | test block-6.1 {blk::isInstrumented} { 154 | set b1 [blk::makeBlock ""] 155 | blk::Instrument $b1 blah 156 | set result [blk::isInstrumented $b1] 157 | blk::release $b1 158 | set result 159 | } 1 160 | test block-6.2 {blk::isInstrumented} { 161 | set b1 [blk::makeBlock ""] 162 | set result [blk::isInstrumented $b1] 163 | blk::release $b1 164 | set result 165 | } 0 166 | 167 | test block-7.1 {blk::getVersion} { 168 | set b1 [blk::makeBlock dummy.tcl] 169 | set result [blk::getVersion $b1] 170 | blk::getSource $b1 171 | lappend result [blk::getVersion $b1] 172 | blk::getSource $b1 173 | lappend result [blk::getVersion $b1] 174 | blk::Instrument $b1 blah 175 | lappend result [blk::getVersion $b1] 176 | blk::getSource $b1 177 | lappend result [blk::getVersion $b1] 178 | blk::Instrument $b1 blah 179 | lappend result [blk::getVersion $b1] 180 | blk::release $b1 181 | set result 182 | } {0 1 2 3 3 4} 183 | 184 | test block-8.1 {blk::getFiles} { 185 | blk::getFiles 186 | } {} 187 | test block-8.2 {blk::getFiles} { 188 | set b1 [blk::makeBlock dummy.tcl] 189 | set result [blk::getFiles] 190 | blk::release $b1 191 | string compare $b1 $result 192 | } 0 193 | test block-8.3 {blk::getFiles} { 194 | set b1 [blk::makeBlock dummy.tcl] 195 | set b2 [blk::makeBlock ""] 196 | set result [blk::getFiles] 197 | blk::release $b1 $b2 198 | string compare $b1 $result 199 | } 0 200 | test block-8.3 {blk::getFiles} { 201 | set b1 [blk::makeBlock dummy.tcl] 202 | set b2 [blk::makeBlock foo] 203 | set result [lsort -integer [blk::getFiles]] 204 | blk::release $b1 $b2 205 | string compare [list $b1 $b2] $result 206 | } 0 207 | test block-8.4 {blk::getFiles} { 208 | set b1 [blk::makeBlock ""] 209 | set b2 [blk::makeBlock ""] 210 | set result [lsort -integer [blk::getFiles]] 211 | blk::release $b1 $b2 212 | string compare "" $result 213 | } 0 214 | 215 | test block-9.1 {blk::SetSource} { 216 | blk::getSource Temp 217 | } {} 218 | test block-9.2 {blk::SetTemp} { 219 | blk::SetSource Temp foobar 220 | blk::getSource Temp 221 | } foobar 222 | test block-9.3 {blk::SetTemp} { 223 | set v [blk::getVersion Temp] 224 | blk::SetSource Temp foobar 225 | expr [blk::getVersion Temp] - $v 226 | } 1 227 | 228 | # blk::setSource has already been tested thoroughly by the previous tests 229 | 230 | file delete dummy.tcl 231 | blk::release all 232 | cd $pwd 233 | cleanupTests 234 | if {[info exists tk_version] && !$tcl_interactive} { 235 | exit 236 | } 237 | -------------------------------------------------------------------------------- /src/tcl/lib/tcldebugger/tests/dbgLaunch.tcl: -------------------------------------------------------------------------------- 1 | # dbgLaunch.tcl 2 | # 3 | # This file contains functions that that enable test scripts to 4 | # excercise the debugger engine and nub without using the GUI. 5 | # 6 | # Copyright (c) 1998-2000 by Ajuba Solutions 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | # Load the minimum set of files needed to get the debugger engine working. 12 | 13 | set odir [pwd] 14 | 15 | cd [file dirname [info script]] 16 | set ::tcltest::testsDirectory [file dirname [pwd]] 17 | 18 | cd $::protest::sourceDirectory 19 | 20 | package require projectInfo 21 | 22 | namespace eval debugger { 23 | variable libdir [pwd] 24 | variable parameters 25 | array set parameters [list \ 26 | aboutImage [file join $libdir images/about.gif] \ 27 | aboutCopyright "testing" \ 28 | appType local \ 29 | iconImage "foo" \ 30 | productName "$::projectInfo::productName Debugger"] 31 | } 32 | 33 | foreach file { 34 | dbg.tcl block.tcl break.tcl coverage.tcl system.tcl 35 | instrument.tcl image.tcl pref.tcl proj.tcl location.tcl util.tcl 36 | } { 37 | source $file 38 | } 39 | 40 | if {[info procs initProject] == {}} { 41 | source [file join [pwd] [file dirname [info script]] initProject.tcl] 42 | } 43 | 44 | cd $odir 45 | 46 | # proj::InitNewProj -- 47 | # 48 | # Override the init routine for projects since it assumes the existence 49 | # of GUI APIs and Windows. 50 | # 51 | # Arguments: 52 | # None. 53 | # 54 | # Results: 55 | # None. 56 | 57 | proc proj::InitNewProj {} { 58 | variable projectOpen 59 | set projectOpen 1 60 | 61 | if {[proj::isRemoteProj]} { 62 | set port [pref::prefGet portRemote] 63 | while {![dbg::setServerPort $port]} { 64 | error "The port you selected is invalid or taken: $port" 65 | } 66 | } 67 | 68 | pref::groupUpdate Project 69 | return 70 | } 71 | 72 | # initDbg -- 73 | # 74 | # Initialize the debugger without launching an application. 75 | # This routine must be called from within the srcs directory. 76 | # 77 | # Arguments: 78 | # None. 79 | # 80 | # Results: 81 | # None. 82 | 83 | proc initDbg {} { 84 | wm geometry . +0+0 85 | 86 | set blk::blockCounter 0 87 | dbg::initialize 88 | 89 | dbg::register linebreak {eventProc linebreak} 90 | dbg::register error {eventProc error} 91 | dbg::register attach {eventProc attach} 92 | dbg::register exit {eventProc exit} 93 | dbg::register cmdresult {eventProc cmdresult} 94 | system::init 95 | return 96 | } 97 | 98 | # quitDbg -- 99 | # 100 | # Stop debugging the application and unregister the eventProcs 101 | # 102 | # Arguments: 103 | # None. 104 | # 105 | # Results: 106 | # None. 107 | 108 | proc quitDbg {} { 109 | catch {dbg::quit; after 100} 110 | dbg::unregister linebreak {eventProc linebreak} 111 | dbg::unregister error {eventProc error} 112 | dbg::unregister attach {eventProc attach} 113 | dbg::unregister exit {eventProc exit} 114 | dbg::unregister cmdresult {eventProc cmdresult} 115 | return 116 | } 117 | 118 | # testDbg -- 119 | # 120 | # Launch the nub on the given script and execute a sequence of 121 | # debugger operations. 122 | # 123 | # Arguments: 124 | # nubScript The script to run in the nub. 125 | # testScript The script to execute in the debugger. 126 | # 127 | # Results: 128 | # Returns the result of the testScript. 129 | 130 | proc testDbg {nubScript testScript {setupScript {}} {exename tclsh}} { 131 | set result {} 132 | set dummy [file join $::tcltest::temporaryDirectory dummy.tcl] 133 | set pwd [pwd] 134 | cd $::protest::sourceDirectory 135 | 136 | set code [catch { 137 | initDbg 138 | makeFile $nubScript $dummy 139 | 140 | # Load the fake project file, extract the app arguments from the 141 | # preferences and set the server listening on some random port. 142 | 143 | if {$::tcl_platform(platform) == "windows"} { 144 | set exeFile ${exename}$::protest::currentVersion(Tcl-short) 145 | } else { 146 | set exeFile ${exename}$::protest::currentVersion(Tcl) 147 | } 148 | initProject MyProject.tpj $dummy {} $::tcltest::temporaryDirectory \ 149 | [findExeFile $exeFile] 150 | set interp [lindex [pref::prefGet appInterpList] 0] 151 | set dir [lindex [pref::prefGet appDirList] 0] 152 | set script [lindex [pref::prefGet appScriptList] 0] 153 | set arg [lindex [pref::prefGet appArgList] 0] 154 | set proj [file tail [proj::getProjectPath]] 155 | dbg::setServerPort random 156 | 157 | # Now run the test script. 158 | set result [uplevel 1 $setupScript] 159 | 160 | # Start the application and wait for the "attach" event. 161 | dbg::start $interp $dir dummy.tcl $arg $proj 162 | waitForApp 163 | 164 | # Step to the first command of the script. 165 | dbg::step any 166 | waitForApp 167 | 168 | # Now run the test script. 169 | set result [uplevel 1 $testScript] 170 | } msg] 171 | 172 | quitDbg 173 | catch {file delete -force $dummy} 174 | cd $pwd 175 | if {$code} { 176 | error $msg $::errorInfo $::errorCode 177 | } 178 | return $result 179 | } 180 | 181 | # launchDbg -- 182 | # 183 | # Start the both the debugger and the application to debug. 184 | # Set up initial communication. 185 | # 186 | # Arguments: 187 | # app Interpreter in which to run scriptFile. 188 | # port Number of port on which to communicate. 189 | # scriptFile File to debug. 190 | # verbose Boolean that decides whether to log activity. 191 | # 192 | # Results: 193 | # Returns the PID of the application. 194 | 195 | proc launchDbg {app scriptFile} { 196 | initDbg 197 | dbg::start $app $::tcltest::temporaryDirectory $scriptFile {} REMOTE 198 | waitForApp 199 | return 200 | } 201 | 202 | # eventProc -- 203 | # 204 | # The proc that is registered to execute when an event is triggered. 205 | # Sets the global variable Dbg_AppStopped to the event to trigger the 206 | # vwait called by the waitForApp proc. 207 | # 208 | # Arguments: 209 | # None. 210 | # 211 | # Results: 212 | # None. 213 | 214 | proc eventProc {event args} { 215 | global Dbg_AppStopped 216 | # puts "EVENT - $event" 217 | set Dbg_AppStopped $event 218 | return 219 | } 220 | 221 | # waitForApp -- 222 | # 223 | # Call this proc after dbg::step, dbg::run, dbg::evaluate. Returns 224 | # when the global variable Dbg_AppStopped is set by the breakProc 225 | # or exitProc procedures. 226 | # 227 | # Arguments: 228 | # None. 229 | # 230 | # Results: 231 | # None. 232 | 233 | proc waitForApp {} { 234 | global Dbg_AppStopped 235 | vwait Dbg_AppStopped 236 | set ret $Dbg_AppStopped 237 | set Dbg_AppStopped "run" 238 | return $ret 239 | } 240 | 241 | -------------------------------------------------------------------------------- /src/tcl/lib/tcldebugger/tests/guiLaunch.tcl: -------------------------------------------------------------------------------- 1 | # tests/debugger/guiLaunch.tcl 2 | # 3 | # This file contains functions that that enable test scripts to 4 | # excercise the debugger GUI. 5 | # 6 | # Copyright (c) 1998-2000 by Ajuba Solutions 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | set odir [pwd] 12 | cd [file dirname [info script]] 13 | cd $::protest::sourceDirectory 14 | 15 | # Load the minimum set of files needed to get the debugger engine working. 16 | 17 | package require projectInfo 18 | package require cmdline 19 | 20 | namespace eval debugger { 21 | variable libdir [pwd] 22 | variable parameters 23 | array set parameters [list \ 24 | aboutImage [file join $libdir images/about.gif] \ 25 | aboutCopyright "testing" \ 26 | appType local \ 27 | iconImage [expr {($::tcl_platform(platform) == "windows") \ 28 | ? "foo" : [file join $libdir images/debugUnixIcon.gif]}]\ 29 | productName "$::projectInfo::productName Debugger"] 30 | 31 | } 32 | 33 | foreach file { 34 | pref.tcl image.tcl system.tcl font.tcl dbg.tcl 35 | break.tcl block.tcl instrument.tcl gui.tcl guiUtil.tcl widget.tcl 36 | bindings.tcl icon.tcl selection.tcl tabnotebook.tcl tkcon.tcl 37 | breakWin.tcl codeWin.tcl coverage.tcl evalWin.tcl file.tcl find.tcl 38 | inspectorWin.tcl menu.tcl prefWin.tcl procWin.tcl 39 | stackWin.tcl toolbar.tcl varWin.tcl watchWin.tcl proj.tcl projWin.tcl 40 | result.tcl portWin.tcl location.tcl util.tcl 41 | } { 42 | source $file 43 | } 44 | 45 | if {[info procs initProject] == {}} { 46 | source [file join [pwd] [file dirname [info script]] initProject.tcl] 47 | } 48 | 49 | cd $odir 50 | 51 | # testGui -- 52 | # 53 | # Test the Debugger's GUI by passing a script to 54 | # be executed in the application, and another script 55 | # to extract the result. 56 | # 57 | # Arguments: 58 | # appScript Script to debug. 59 | # testScript Script to run in debugger's interp. 60 | # 61 | # Results: 62 | # The result of the testScript. 63 | 64 | proc testGui {appScript testScript {setupScript ""}} { 65 | set result {} 66 | set oldpwd [pwd] 67 | 68 | set code [catch { 69 | cd $::protest::sourceDirectory 70 | initGui 71 | 72 | # Launch a project that uses the appScript 73 | 74 | makeFile $appScript \ 75 | [file join $::tcltest::temporaryDirectory dummy.tcl] 76 | initProject "Ray's Breath Smells Like Cat Food.tpj" \ 77 | [file join $::tcltest::temporaryDirectory dummy.tcl] {} . \ 78 | [info nameofexecutable] 79 | 80 | # Run the setupScript to set up special project or debugger state, 81 | # such as adding bpts. 82 | 83 | if {$setupScript != ""} { 84 | set result [uplevel 1 $setupScript] 85 | } 86 | 87 | # Stop at the first command in appScript 88 | 89 | gui::run dbg::step 90 | waitForApp 91 | waitForApp 92 | 93 | # Run the testScript to simulate user actions and introspect on the 94 | # debugger's state. 95 | 96 | set result [uplevel 1 $testScript] 97 | } msg] 98 | 99 | # delete the appScript file, and cleanup the debugger's state. 100 | 101 | quitGui 102 | catch {file delete -force \ 103 | [file join $::tcltest::temporaryDirectory dummy.tcl]} 104 | cleanProjectFiles 105 | cd $oldpwd 106 | 107 | # throw and error or return the result of the testScript. 108 | 109 | if {$code} { 110 | error $msg $::errorInfo $::errorCode 111 | } 112 | return $result 113 | } 114 | 115 | # initGui -- 116 | # 117 | # Initialize the GUI and the nub. 118 | # 119 | # Arguments: 120 | # None. 121 | # 122 | # Results: 123 | # None. 124 | 125 | proc initGui {} { 126 | wm geometry . +0+0 127 | 128 | dbg::register linebreak {eventProc linebreak gui::linebreakHandler} 129 | dbg::register varbreak {eventProc varbreak gui::varbreakHandler} 130 | dbg::register error {eventProc error gui::errorHandler} 131 | dbg::register result {eventProc result gui::resultHandler} 132 | dbg::register attach {eventProc attach gui::attachHandler} 133 | dbg::register exit {eventProc exit {}} 134 | dbg::register cmdresult {eventProc cmdresult gui::cmdresultHandler} 135 | 136 | system::init 137 | font::configure [pref::prefGet fontType] [pref::prefGet fontSize] 138 | 139 | dbg::initialize 140 | 141 | gui::showMainWindow 142 | wm geometry $::gui::gui(mainDbgWin) +0+0 143 | wm deiconify $::gui::gui(mainDbgWin) 144 | return 145 | } 146 | 147 | # quitGui -- 148 | # 149 | # Remove the registered commands. 150 | # 151 | # Arguments: 152 | # None. 153 | # 154 | # Results: 155 | # None. 156 | 157 | proc quitGui {} { 158 | foreach a [after info] { 159 | after cancel $a 160 | } 161 | catch {dbg::quit} 162 | catch {eval destroy [winfo children .]} 163 | file::update 1 164 | catch {unset gui::format} 165 | gui::setCurrentState new 166 | 167 | after 100 168 | 169 | dbg::unregister linebreak {eventProc linebreak gui::linebreakHandler} 170 | dbg::unregister varbreak {eventProc varbreak gui::varbreakHandler} 171 | dbg::unregister error {eventProc error gui::errorHandler} 172 | dbg::unregister result {eventProc result gui::resultHandler} 173 | dbg::unregister attach {eventProc attach gui::attachHandler} 174 | dbg::unregister exit {eventProc exit {}} 175 | dbg::unregister cmdresult {eventProc cmdresult gui::cmdresultHandler} 176 | return 177 | } 178 | 179 | # eventProc -- 180 | # 181 | # The proc that is registered to execute when an event is triggered. 182 | # Sets the global variable Gui_AppStopped to the event to trigger the 183 | # vwait called by the waitForAppp proc. 184 | # 185 | # Arguments: 186 | # None. 187 | # 188 | # Results: 189 | # None. 190 | 191 | proc eventProc {event cmd args} { 192 | global Gui_AppStopped 193 | # puts "EVENT - $event" 194 | if {$cmd != {}} { 195 | if {[catch {eval $cmd $args} msg]} { 196 | puts "Error $::errorInfo" 197 | } 198 | } 199 | set Gui_AppStopped $event 200 | return 201 | } 202 | 203 | # waitForApp -- 204 | # 205 | # Call this proc after dbg::step, dbg::run, dbg::evaluate. Returns 206 | # when the global variable Gui_AppStopped is set by the breakProc 207 | # or exitProc procedures. 208 | # 209 | # Arguments: 210 | # None. 211 | # 212 | # Results: 213 | # None. 214 | 215 | proc waitForApp {} { 216 | global Gui_AppStopped 217 | vwait Gui_AppStopped 218 | return 219 | } 220 | 221 | -------------------------------------------------------------------------------- /src/tcl/lib/tcldebugger/tests/initProject.tcl: -------------------------------------------------------------------------------- 1 | # initProject -- 2 | # 3 | # Initialize the Project group and the GlobalDefault group to a clean 4 | # state. Also, hard code the project path and application arguments 5 | # so the project can actually start executing code. 6 | # 7 | # Arguments: 8 | # projPath 9 | # script 10 | # arg 11 | # dir 12 | # interp 13 | # 14 | # Results: 15 | # None. 16 | 17 | proc initProject {projPath script arg dir interp} { 18 | cleanProject 19 | 20 | initGlobalDefault 21 | 22 | pref::groupInit Project [list \ 23 | appScript {} {} \ 24 | appArg {} {} \ 25 | appDir {} {} \ 26 | appInterp {} {} \ 27 | appScriptList [list $script] {} \ 28 | appArgList [list $arg] {} \ 29 | appDirList [list $dir] {} \ 30 | appInterpList [list $interp] {} \ 31 | appType local {} \ 32 | breakList {} {} \ 33 | errorAction 1 {} \ 34 | dontInstrument {} {} \ 35 | instrumentDynamic 1 {} \ 36 | instrumentIncrTcl 1 {} \ 37 | instrumentExpect 1 {} \ 38 | instrumentTclx 1 {} \ 39 | noAutoLoad 1 {} \ 40 | portRemote 2576 {} \ 41 | projRemote 0 {} \ 42 | projVersion 1.0 {} \ 43 | prevViewFile {} {} \ 44 | ] 45 | 46 | proj::setProjectPath $projPath 47 | proj::InitNewProj 48 | return 49 | } 50 | 51 | # initRemoteProject -- 52 | # 53 | # Initialize the Project group and the GlobalDefault group to a clean 54 | # state. Make the loaded pojec a remote project. 55 | # 56 | # Arguments: 57 | # projPath 58 | # port 59 | # 60 | # Results: 61 | # None. 62 | 63 | proc initRemoteProject {projPath port} { 64 | # Create the project and global preferences. 65 | initProject $projPath {} {} {} {} 66 | 67 | # Turn the existing project into a remote project. 68 | 69 | pref::prefNew Project portRemote $port {} 70 | pref::prefNew Project appType remote {} 71 | 72 | # Update the state to the GUI. 73 | 74 | proj::setProjectPath $projPath 75 | proj::InitNewProj 76 | return 77 | } 78 | 79 | # initGlobalDefault -- 80 | # 81 | # Initialize the GlobalDefault group. 82 | # 83 | # Arguments: 84 | # None. 85 | # 86 | # Results: 87 | # None. 88 | 89 | proc initGlobalDefault {} { 90 | pref::groupInit GlobalDefault [list \ 91 | browserCmd [system::getBrowserCmd] {} \ 92 | browserDefault [system::getDefBrowser] {} \ 93 | comboListSize 10 {} \ 94 | exitPrompt kill {} \ 95 | fileOpenDir [pwd] {} \ 96 | fontSize 10 {} \ 97 | fontType courier {} \ 98 | highlight lightblue {} \ 99 | highlight_error red {} \ 100 | highlight_cmdresult #ffff80 {} \ 101 | historySize 64 {} \ 102 | paneGeom {} {} \ 103 | projectList {} {} \ 104 | projectPrev {} {} \ 105 | projectReload 1 {} \ 106 | screenSize 300 {} \ 107 | tabSize 8 {} \ 108 | tclHelpFile {} {} \ 109 | showCodeLines 1 {} \ 110 | showResult 1 {} \ 111 | showStatusBar 1 {} \ 112 | showToolbar 1 {} \ 113 | warnOnKill 1 {} \ 114 | warnOnClose 0 {} \ 115 | warnInvalidBp 0 {} \ 116 | winGeoms {} {} \ 117 | ] 118 | 119 | # Only set the widget attributes if we have loaded the image 120 | # file. If it hasn't been loaded, we assume the tests are non 121 | # gui test and therefore have not sourced needed files. 122 | 123 | if {[lsearch [namespace children ::] ::image] >= 0} { 124 | system::setWidgetAttributes 125 | } 126 | 127 | return 128 | } 129 | 130 | # initProjectDefault -- 131 | # 132 | # Initialize the ProjectDefault group. 133 | # 134 | # Arguments: 135 | # None. 136 | # 137 | # Results: 138 | # None. 139 | 140 | proc initProjectDefault {} { 141 | pref::groupInit ProjectDefault [list \ 142 | appScript {} projWin::updateScriptList \ 143 | appArg {} projWin::updateArgList \ 144 | appDir {} projWin::updateDirList \ 145 | appInterp [system::getInterps] projWin::updateInterpList \ 146 | appScriptList {} {} \ 147 | appArgList {} {} \ 148 | appDirList {} {} \ 149 | appInterpList [system::getInterps] {} \ 150 | appType local {} \ 151 | breakList {} {} \ 152 | errorAction 1 dbg::initInstrument \ 153 | dontInstrument {} dbg::initInstrument \ 154 | instrumentDynamic 1 dbg::initInstrument \ 155 | instrumentIncrTcl 1 projWin::updateIncrTcl \ 156 | instrumentExpect 1 projWin::updateExpect \ 157 | instrumentTclx 1 projWin::updateTclX \ 158 | autoLoad 0 dbg::initInstrument \ 159 | portRemote 2576 projWin::updatePort \ 160 | projVersion 1.0 {} \ 161 | prevViewFile {} {} \ 162 | watchList {} {} \ 163 | ] 164 | return 165 | } 166 | 167 | # initProjectFiles -- 168 | # 169 | # Initialize the various project files. 170 | # 171 | # Arguments: 172 | # dummy The name of a dummy file. 173 | # 174 | # Results: 175 | # None. 176 | 177 | proc initProjectFiles {dummy} { 178 | global projDir 179 | global corruptProj 180 | global noreadProj 181 | global nowriteProj 182 | global localProj 183 | global remoteProj 184 | global tcl_platform 185 | 186 | set projDir $::tcltest::temporaryDirectory 187 | set corruptProj [file join $projDir Corrupt.tpj] 188 | set noreadProj [file join $projDir NoReadPerm.tpj] 189 | set nowriteProj [file join $projDir NoWritePerm.tpj] 190 | set localProj [file join $projDir Local.tpj] 191 | set remoteProj [file join $projDir Remote.tpj] 192 | 193 | set proj::projectOpen 1 194 | 195 | set file [open $::corruptProj w] 196 | puts $file "set" 197 | close $file 198 | 199 | proj::setProjectPath $noreadProj 200 | pref::groupNew Project {proj::SaveProjCmd [proj::getProjectPath]} {} 201 | pref::groupCopy ProjectDefault Project 202 | proj::saveProj $noreadProj 203 | pref::groupDelete Project 204 | 205 | proj::setProjectPath $nowriteProj 206 | pref::groupNew Project {proj::SaveProjCmd [proj::getProjectPath]} {} 207 | pref::groupCopy ProjectDefault Project 208 | proj::saveProj $nowriteProj 209 | pref::groupDelete Project 210 | 211 | if {$tcl_platform(platform) == "windows"} { 212 | file attribute $nowriteProj -readonly 1 213 | set exeName tclsh$::protest::currentVersion(Tcl-short) 214 | } else { 215 | file attribute $noreadProj -permissions 0000 216 | file attribute $nowriteProj -permissions 0400 217 | set exeName tclsh$::protest::currentVersion(Tcl) 218 | } 219 | proj::setProjectPath $localProj 220 | pref::groupNew Project {proj::SaveProjCmd [proj::getProjectPath]} {} 221 | pref::groupCopy ProjectDefault Project 222 | pref::prefSet Project appScriptList [list $dummy] 223 | pref::prefSet Project appArgList {} 224 | pref::prefSet Project appDirList [list [file dirname $dummy]] 225 | pref::prefSet Project appInterpList [list [findExeFile $exeName]] 226 | proj::saveProj $localProj 227 | pref::groupDelete Project 228 | 229 | proj::setProjectPath $remoteProj 230 | pref::groupNew Project {proj::SaveProjCmd [proj::getProjectPath]} {} 231 | pref::groupCopy ProjectDefault Project 232 | pref::prefSet Project appType remote 233 | proj::saveProj $remoteProj 234 | pref::groupDelete Project 235 | 236 | set proj::projectOpen 0 237 | pref::prefSet GlobalDefault projectList {} 238 | return 239 | } 240 | 241 | # cleanProject -- 242 | # 243 | # Reset all of the project state. 244 | # 245 | # Arguments: 246 | # None. 247 | # 248 | # Results: 249 | # None. 250 | 251 | proc cleanProject {} { 252 | set proj::projectOpen 0 253 | set proj::projectNeverSaved 0 254 | 255 | if {[pref::groupExists Temp]} { 256 | pref::groupDelete Temp 257 | } 258 | if {[pref::groupExists Project]} { 259 | pref::groupDelete Project 260 | } 261 | 262 | cleanProjectFiles 263 | 264 | return 265 | } 266 | 267 | # cleanProjectFiles -- 268 | # 269 | # Remove the project files. 270 | # 271 | # Arguments: 272 | # None. 273 | # 274 | # Results: 275 | # None. 276 | 277 | proc cleanProjectFiles {} { 278 | global projDir 279 | global corruptProj 280 | global noreadProj 281 | global nowriteProj 282 | global localProj 283 | global remoteProj 284 | global tcl_platform 285 | 286 | if {![info exists projDir]} { 287 | return 288 | } 289 | 290 | if {$tcl_platform(platform) == "windows"} { 291 | file attribute $nowriteProj -readonly 0 292 | } else { 293 | file attribute $noreadProj -permissions 0755 294 | file attribute $nowriteProj -permissions 0755 295 | } 296 | 297 | catch {file delete -force $corruptProj} 298 | catch {file delete -force $noreadProj} 299 | catch {file delete -force $nowriteProj} 300 | catch {file delete -force $localProj} 301 | catch {file delete -force $remoteProj} 302 | 303 | catch {unset corruptProj} 304 | catch {unset noreadProj} 305 | catch {unset nowriteProj} 306 | catch {unset localProj} 307 | catch {unset remoteProj} 308 | 309 | return 310 | } 311 | 312 | # Project Save and Restore Commands -- 313 | # 314 | # Redifine the save and restore commands for Unix and Windows so that 315 | # user preferences do not interfere with tests. 316 | # 317 | # Arguments: 318 | # group The name of the group to restore preferences into. 319 | # 320 | # Results: 321 | # Return a boolean, 1 means that the save did not succeed, 322 | # 0 means it succeeded. 323 | 324 | proc system::winRestoreCmd {group} { 325 | return 0 326 | } 327 | 328 | proc system::winSaveCmd {group} { 329 | return 0 330 | } 331 | 332 | proc system::unixRestoreCmd {group} { 333 | return 0 334 | } 335 | 336 | proc system::unixSaveCmd {group} { 337 | return 0 338 | } 339 | -------------------------------------------------------------------------------- /src/tcl/lib/tcldebugger/tests/initdebug.test: -------------------------------------------------------------------------------- 1 | # This file contains tests for the initdebug.tcl file. 2 | # 3 | # This file contains a collection of tests for one or more of the Tcl 4 | # built-in commands. Sourcing this file into Tcl runs the tests and 5 | # generates output for errors. No output means no errors were found. 6 | # 7 | # Copyright (c) 1998-2000 by Ajuba Solutions 8 | # Copyright (c) 2017 Forward Folio LLC 9 | # 10 | # See the file "license.terms" for information on usage and redistribution 11 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. 12 | # 13 | 14 | if {[string compare test [info procs test]] == 1} { 15 | lappend auto_path [file join [file dirname [info script]] ..] 16 | package require protest 17 | namespace import ::protest::* 18 | } 19 | 20 | catch {parse} parseMsg 21 | if {[regexp "invalid command" $parseMsg]} { 22 | package require parser 23 | } 24 | 25 | if {[string compare testGui [info procs launchDbg]] == 1} { 26 | source [file join [pwd] [file dirname [info script]] dbgLaunch.tcl] 27 | } 28 | 29 | set testFile [file join $::tcltest::temporaryDirectory test.tcl] 30 | set outputFile [file join $::tcltest::temporaryDirectory output] 31 | 32 | file copy -force [file join $::protest::sourceDirectory initdebug.tcl] $::tcltest::temporaryDirectory 33 | 34 | set pwd [pwd] 35 | cd $::protest::sourceDirectory 36 | 37 | proc launchTest {script {bg 0}} { 38 | global testFile 39 | 40 | set pwd [pwd] 41 | cd $::tcltest::temporaryDirectory 42 | makeFile $script $testFile 43 | if {$bg} { 44 | exec [info nameofexecutable] $testFile & 45 | } else { 46 | exec [info nameofexecutable] $testFile 47 | } 48 | cd $pwd 49 | return 50 | } 51 | 52 | test initdebug-1.1 {debugger_init} { 53 | file delete -force $outputFile 54 | launchTest { 55 | set f [open output w] 56 | source initdebug.tcl 57 | puts "SOURCED" 58 | if {[debugger_init]} { 59 | puts $f succeed 60 | } else { 61 | puts $f failed 62 | } 63 | puts "SAVED" 64 | close $f 65 | exit 66 | } 67 | set f [open $::outputFile r] 68 | set result [read $f] 69 | close $f 70 | set result 71 | } "failed\n" 72 | test initdebug-1.2 {debugger_init} { 73 | initDbg 74 | initRemoteProject REMOTE 5321 75 | launchTest { 76 | set f [open output w] 77 | source initdebug.tcl 78 | if {[debugger_init 127.0.0.1 5321]} { 79 | puts $f succeed 80 | } else { 81 | puts $f failed 82 | } 83 | close $f 84 | exit 85 | } 1 86 | set result [waitForApp] ;# Attach 87 | dbg::step run 88 | lappend result [waitForApp] ;# Exit 89 | set f [open $outputFile r] 90 | lappend result [read $f] 91 | close $f 92 | dbg::quit 93 | set result 94 | } "attach exit {succeed\n}" 95 | 96 | test initdebug-2.1 {debugger_eval} { 97 | file delete -force $outputFile 98 | launchTest { 99 | set f [open output w] 100 | source initdebug.tcl 101 | catch {debugger_eval} result 102 | puts $f $result 103 | close $f 104 | exit 105 | } 106 | set f [open $outputFile r] 107 | set result [read $f] 108 | close $f 109 | set result 110 | } {wrong # args: should be "debugger_eval ?options? script" 111 | } 112 | test initdebug-2.2 {debugger_eval} { 113 | file delete -force $outputFile 114 | launchTest { 115 | set f [open output w] 116 | source initdebug.tcl 117 | catch {debugger_eval {set x 2}} result 118 | puts $f $result 119 | puts $f [set x] 120 | close $f 121 | exit 122 | } 123 | set f [open $outputFile r] 124 | set result [read $f] 125 | close $f 126 | set result 127 | } "2\n2\n" 128 | 129 | test initdebug-3.1 {debugger_attached} { 130 | file delete -force $outputFile 131 | launchTest { 132 | set f [open output w] 133 | source initdebug.tcl 134 | set result [debugger_attached] 135 | puts $f $result 136 | close $f 137 | exit 138 | } 139 | set f [open $outputFile r] 140 | set result [read $f] 141 | close $f 142 | set result 143 | } "0\n" 144 | test initdebug-3.2 {debugger_attached} { 145 | initDbg 146 | initRemoteProject REMOTE 5321 147 | launchTest { 148 | set f [open output w] 149 | fconfigure $f -buffering none 150 | source initdebug.tcl 151 | if {[debugger_init 127.0.0.1 5321]} { 152 | puts $f succeed 153 | } else { 154 | puts $f failed 155 | } 156 | puts $f [debugger_attached] 157 | close $f 158 | exit 159 | } 1 160 | 161 | waitForApp 162 | dbg::step run 163 | after 500 164 | dbg::quit 165 | set f [open $outputFile r] 166 | set result [read $f] 167 | close $f 168 | set result 169 | } "succeed\n1\n" 170 | test initdebug-3.3 {debugger_attached} { 171 | initDbg 172 | initRemoteProject REMOTE 5321 173 | launchTest { 174 | set f [open output w] 175 | fconfigure $f -buffering none 176 | source initdebug.tcl 177 | if {[debugger_init 127.0.0.1 5321]} { 178 | puts $f succeed 179 | } else { 180 | puts $f failed 181 | } 182 | puts $f [debugger_attached] 183 | puts $f [debugger_eval {set x eval}] 184 | puts $f [debugger_attached] 185 | close $f 186 | exit 187 | } 1 188 | 189 | waitForApp 190 | dbg::step any 191 | waitForApp 192 | set dbg::appHost {} 193 | dbg::quit 194 | after 500 195 | set f [open $outputFile r] 196 | set result [read $f] 197 | close $f 198 | set result 199 | } "succeed\n1\neval\n0\n" 200 | 201 | test initdebug-4.1 {sentinel, multiple sourcing of initdebug.tcl} { 202 | initDbg 203 | initRemoteProject REMOTE 5321 204 | launchTest { 205 | set f [open output w] 206 | source initdebug.tcl 207 | if {[debugger_init 127.0.0.1 5321]} { 208 | puts $f succeed 209 | puts $f [debugger_attached] 210 | source initdebug.tcl 211 | puts $f [debugger_attached] 212 | } else { 213 | puts $f failed 214 | } 215 | close $f 216 | exit 217 | } 1 218 | set result [waitForApp] ;# Attach 219 | dbg::step run 220 | lappend result [waitForApp] ;# Exit 221 | set f [open $outputFile r] 222 | lappend result [read $f] 223 | close $f 224 | dbg::quit 225 | set result 226 | } "attach exit {succeed 227 | 1 228 | 1 229 | }" 230 | 231 | catch {file delete -force $outputFile} 232 | catch {file delete -force $testFile} 233 | catch {file delete -force [file join $::tcltest::temporaryDirectory initdebug.tcl]} 234 | 235 | cd $pwd 236 | 237 | cleanupTests 238 | 239 | if {[info exists tk_version] && !$tcl_interactive} { 240 | exit 241 | } 242 | -------------------------------------------------------------------------------- /src/tcl/lib/tcldebugger/tests/pkgIndex.tcl: -------------------------------------------------------------------------------- 1 | # Tcl package index file, version 1.1 2 | # This file is generated by the "pkg_mkIndex -direct" command 3 | # and sourced either when an application starts up or 4 | # by a "package unknown" script. It invokes the 5 | # "package ifneeded" command to set up package-related 6 | # information so that packages will be loaded automatically 7 | # in response to "package require" commands. When this 8 | # script is sourced, the variable $dir must contain the 9 | # full path name of this file's directory. 10 | 11 | package ifneeded protest 1.0 [list source [file join $dir protest.tcl]] 12 | -------------------------------------------------------------------------------- /src/tcl/lib/tcldebugger/tests/startup.tcl: -------------------------------------------------------------------------------- 1 | # startup.tcl -- 2 | # 3 | # This file is the primary entry point for the 4 | # TclPro Debugger. 5 | # 6 | # Copyright (c) 1999-2000 by Ajuba Solutions. 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | # Initialize the debugger library 12 | 13 | package require projectInfo 14 | 15 | # Specify the additional debugger parameters. 16 | 17 | set parameters [list \ 18 | aboutCmd {::TclProAboutBox images/about.gif images/logo.gif} \ 19 | aboutCopyright "$::projectInfo::copyright\nVersion $::projectInfo::patchLevel" \ 20 | appType remote \ 21 | ] 22 | 23 | if {$::tcl_platform(platform) == "windows"} { 24 | package require Winico 25 | lappend parameters iconImage [winico load dbg scicons.dll] 26 | } else { 27 | lappend parameters iconImage images/debugUnixIcon.gif 28 | } 29 | 30 | # ::TclProAboutBox -- 31 | # 32 | # This procedure displays the TclPro about box or 33 | # splash screen. 34 | # 35 | # Arguments: 36 | # image The main image to display in the about box. 37 | # 38 | # Results: 39 | # None. 40 | 41 | proc ::TclProAboutBox {aboutImage logoImage} { 42 | catch {destroy .about} 43 | 44 | # Create an undecorated toplevel with a raised bevel 45 | set top [toplevel .about -bd 4 -relief raised] 46 | wm overrideredirect .about 1 47 | 48 | # This is a hack to get around a Tk bug. Once Tk is fixed, we can 49 | # let the geometry computations happen off-screen 50 | wm geom .about 1x1 51 | # wm withdraw .about 52 | 53 | # Create a container frame so we can set the background without 54 | # affecting the color of the outermost bevel. 55 | set f1 [frame .about.f -bg white] 56 | pack $f1 -fill both 57 | 58 | # Create the images 59 | 60 | image create photo about -file $aboutImage 61 | image create photo logo -file $logoImage 62 | 63 | # Compute various metrics 64 | set logoWidth [image width logo] 65 | set aboutWidth [image width about] 66 | set screenWidth [winfo screenwidth .] 67 | set screenHeight [winfo screenheight .] 68 | 69 | label $f1.about -bd 0 -bg white -padx 0 -pady 0 -highlightthickness 0 \ 70 | -image about 71 | pack $f1.about -side top -anchor nw 72 | 73 | set f2 [frame $f1.f2 -bg white -bd 0] 74 | pack $f2 -padx 6 -pady 6 -side bottom -fill both -expand 1 75 | 76 | label $f2.logo -bd 0 -bg white -padx 0 -pady 0 -highlightthickness 0 \ 77 | -image logo 78 | pack $f2.logo -side left -anchor nw -padx 0 -pady 0 79 | 80 | set okBut [button $f2.ok -text "OK" -width 6 -default active \ 81 | -command {destroy .about}] 82 | pack $okBut -side right -anchor se -padx 0 -pady 0 83 | 84 | label $f2.version -bd 0 -bg white -padx 10 -pady 0 -highlightthickness 0 \ 85 | -text $::debugger::parameters(aboutCopyright) -justify left 86 | pack $f2.version -side top -anchor nw 87 | 88 | label $f2.url -bd 0 -bg white -padx 10 -pady 0 -highlightthickness 0 \ 89 | -text "http://www.scriptics.com" -fg blue \ 90 | -cursor hand2 91 | pack $f2.url -side top -anchor nw 92 | 93 | # Establish dialog bindings 94 | 95 | bind .about <1> { 96 | raise .about 97 | } 98 | bind $f2.url { 99 | destroy .about 100 | system::openURL http://www.scriptics.com 101 | } 102 | bind .about "$okBut invoke" 103 | 104 | # Add the Windows-only console hack 105 | 106 | if {$::tcl_platform(platform) == "windows"} { 107 | bind $okBut { 108 | console show 109 | destroy .about; break 110 | } 111 | } 112 | 113 | # Place the window in the center of the screen 114 | update 115 | set width [winfo reqwidth .about] 116 | set height [winfo reqheight .about] 117 | set x [expr {([winfo screenwidth .]/2) - ($width/2)}] 118 | set y [expr {([winfo screenheight .]/2) - ($height/2)}] 119 | wm deiconify .about 120 | wm geom .about ${width}x${height}+${x}+${y} 121 | 122 | catch { 123 | focus -force $okBut 124 | grab -global .about 125 | } 126 | 127 | # Return the about window so we can destroy it from external bindings 128 | # if necessary. 129 | return .about 130 | } 131 | 132 | 133 | package require debugger 134 | debugger::init $argv $parameters 135 | 136 | # Add the TclPro debugger extensions 137 | 138 | #Source xmlview.tcl 139 | 140 | # Enter the event loop. 141 | -------------------------------------------------------------------------------- /src/tcl/lib/tcldebugger/tests/system.test: -------------------------------------------------------------------------------- 1 | # This file contains tests for the system.tcl file. 2 | # 3 | # Copyright (c) 1999-2000 by Ajuba Solutions. 4 | # Copyright (c) 2017 Forward Folio LLC 5 | # See the file "license.terms" for information on usage and redistribution of this file. 6 | # 7 | 8 | if {[string compare test [info procs test]] == 1} { 9 | lappend auto_path [file join [file dirname [info script]] ..] 10 | package require protest 11 | namespace import ::protest::* 12 | } 13 | 14 | catch {parse} parseMsg 15 | if {[regexp "invalid command" $parseMsg]} { 16 | package require parser 17 | } 18 | 19 | namespace eval debugger { 20 | variable libdir [file dirname [file dirname [info script]]] 21 | } 22 | 23 | # Windows files need .exe extensions 24 | namespace eval system { 25 | variable exeString 26 | if {$tcl_platform(platform) == "windows"} { 27 | set exeString ".exe" 28 | } else { 29 | set exeString "" 30 | } 31 | } 32 | 33 | package require projectInfo 34 | 35 | # Some tests in this file cannot run with a Debug exedir 36 | 37 | set tclTail $::projectInfo::executable(tclsh) 38 | set tkTail $::projectInfo::executable(wish) 39 | 40 | set tclExe [file exists [file join $::protest::executableDirectory \ 41 | "$tclTail$::system::exeString"]] 42 | set tkExe [file exists [file join $::protest::executableDirectory \ 43 | "$tkTail$::system::exeString"]] 44 | 45 | set ::tcltest::testConstraints(skipIfBuild) \ 46 | [expr {[file exists $tclExe]}] 47 | 48 | source [file join $::protest::sourceDirectory system.tcl] 49 | source [file join $::protest::sourceDirectory block.tcl] 50 | source [file join $::protest::sourceDirectory instrument.tcl] 51 | source [file join $::protest::sourceDirectory location.tcl] 52 | source [file join $::protest::sourceDirectory util.tcl] 53 | source [file join $::protest::sourceDirectory image.tcl] 54 | 55 | test system-1.1 {system::getInterps returns correct tclsh} {skipIfBuild} { 56 | set interpList [system::getInterps] 57 | set result $interpList 58 | foreach interp $interpList { 59 | if {[file tail $interp] == $tclTail} { 60 | set result $interp 61 | break 62 | } 63 | } 64 | set result 65 | } [file join [file dirname [info nameofexecutable]] $tclTail] 66 | 67 | test system-1.2 {system::getInterps returns correct wish} {skipIfBuild} { 68 | set interpList [system::getInterps] 69 | set result $interpList 70 | foreach interp $interpList { 71 | if {[file tail $interp] == $tkTail} { 72 | set result $interp 73 | break 74 | } 75 | } 76 | set result 77 | } [file join [file dirname [info nameofexecutable]] $tkTail] 78 | 79 | test system-1.3 {system::setWidgetAttributes sets all colors as 12 digit hex}\ 80 | {unix skipIfBuild} { 81 | # save current color info 82 | set origColor [. cget -bg] 83 | # change the color of . to something whose rgb is small numbers 84 | . configure -bg "#1B005D006C00" 85 | system::setWidgetAttributes 86 | # now make sure each color is 12 digits long, plus the # sign 87 | set result "" 88 | foreach c [array names system::color] { 89 | if {[string length $system::color($c)]!=13} { 90 | lappend result "color($c)=$system::color($c), which is invalid" 91 | } 92 | } 93 | # restore color to original 94 | . configure -bg $origColor 95 | system::setWidgetAttributes 96 | set result 97 | } {} 98 | 99 | # cleanup 100 | cleanupTests 101 | if {[info exists tk_version] && !$tcl_interactive} { 102 | exit 103 | } 104 | -------------------------------------------------------------------------------- /src/tcl/lib/tcldebugger/toolbar.tcl: -------------------------------------------------------------------------------- 1 | # toolbar.tcl -- 2 | # 3 | # This file implements the Tcl Debugger toolbar. 4 | # 5 | # Copyright (c) 1998-2000 Ajuba Solutions 6 | # Copyright (c) 2017 Forward Folio LLC 7 | # See the file "license.terms" for information on usage and redistribution of this file. 8 | # 9 | 10 | namespace eval tool { 11 | # Array used to store handles to all of the toolbar buttons. 12 | 13 | variable tool 14 | 15 | # Store the top frame of the toolbar. 16 | 17 | variable toolbarFrm 18 | } 19 | 20 | # tool::createWindow -- 21 | # 22 | # Load the button images, create the buttons and add the callbacks. 23 | # 24 | # Arguments: 25 | # mainDbgWin The toplevel window for the main debugger. 26 | # 27 | # Results: 28 | # The handle to the frame that contains all of the toolbar buttons. 29 | 30 | proc tool::createWindow {mainDbgWin} { 31 | variable tool 32 | variable toolbarFrm 33 | 34 | set toolbarFrm [frame $mainDbgWin.tool -bd 2 -relief groove] 35 | 36 | set tool(run) [tool::createButton $toolbarFrm.runButt $image::image(run) \ 37 | {Run until break or EOF.} \ 38 | {gui::run dbg::run}] 39 | set tool(into) [tool::createButton $toolbarFrm.intoButt $image::image(into) \ 40 | {Step into the next procedure.} \ 41 | {gui::run dbg::step}] 42 | set tool(over) [tool::createButton $toolbarFrm.overButt $image::image(over) \ 43 | {Step over the next procedure.} \ 44 | {gui::run {dbg::step over}}] 45 | set tool(out) [tool::createButton $toolbarFrm.outButt $image::image(out) \ 46 | {Step out of the current procedure.} \ 47 | {gui::run {dbg::step out}}] 48 | set tool(to) [tool::createButton $toolbarFrm.toButt $image::image(to) \ 49 | {Run to cursor.} \ 50 | {gui::runTo}] 51 | set tool(cmdresult) [tool::createButton $toolbarFrm.cmdresultButt \ 52 | $image::image(cmdresult) \ 53 | {Step to result of current command.} \ 54 | {gui::run {dbg::step cmdresult}}] 55 | pack [frame $toolbarFrm.sep1 -bd 4 -relief groove -width 2] \ 56 | -pady 2 -fill y -side left 57 | set tool(stop) [tool::createButton $toolbarFrm.stopButt $image::image(stop) \ 58 | {Stop at the next instrumented statement.} \ 59 | {gui::interrupt}] 60 | set tool(kill) [tool::createButton $toolbarFrm.killButt $image::image(kill) \ 61 | {Kill the current application.} \ 62 | {gui::kill}] 63 | set tool(restart) [tool::createButton $toolbarFrm.restartButt \ 64 | $image::image(restart) \ 65 | {Restart the application.} \ 66 | {proj::restartProj}] 67 | pack [frame $toolbarFrm.sep2 -bd 4 -relief groove -width 2] \ 68 | -pady 2 -fill y -side left 69 | set tool(refreshFile) [tool::createButton $toolbarFrm.refreshFileButt \ 70 | $image::image(refreshFile) \ 71 | {Refresh the current file.} \ 72 | {menu::refreshFile}] 73 | 74 | pack [frame $toolbarFrm.sep3 -bd 4 -relief groove -width 2] \ 75 | -pady 2 -fill y -side left 76 | set tool(win_break) [tool::createButton $toolbarFrm.win_breakButt \ 77 | $image::image(win_break) \ 78 | {Display the Breakpoint Window.} \ 79 | {bp::showWindow}] 80 | set tool(win_eval) [tool::createButton $toolbarFrm.win_evalButt \ 81 | $image::image(win_eval) \ 82 | {Display the Eval Console Window.} \ 83 | {evalWin::showWindow}] 84 | set tool(win_proc) [tool::createButton $toolbarFrm.win_procButt \ 85 | $image::image(win_proc) \ 86 | {Display the Procedure Window.} \ 87 | {procWin::showWindow}] 88 | set tool(win_watch) [tool::createButton $toolbarFrm.win_watchButt \ 89 | $image::image(win_watch) \ 90 | {Display the Watch Variables Window.} \ 91 | {watch::showWindow}] 92 | 93 | return $toolbarFrm 94 | } 95 | 96 | # tool::addButton -- 97 | # 98 | # Append a new button at the end of the toolbar. 99 | # 100 | # Arguments: 101 | # name The name of the button to create. 102 | # img An image that has already beeen created. 103 | # txt Text to display in the help window. 104 | # cmd Command to execute when pressed. 105 | # 106 | # Results: 107 | # Returns the widget name for the button. 108 | 109 | proc tool::addButton {name img txt cmd} { 110 | variable tool 111 | variable toolbarFrm 112 | 113 | set tool($name) [tool::createButton $toolbarFrm.$name $img \ 114 | $txt $cmd] 115 | return $tool($name) 116 | } 117 | 118 | # tool::createButton -- 119 | # 120 | # Create uniform toolbar buttons and add bindings. 121 | # 122 | # Arguments: 123 | # but The name of the button to create. 124 | # img An image that has already beeen created. 125 | # txt Text to display in the help window. 126 | # cmd Command to execute when pressed. 127 | # side The default is to add the on the left side of the 128 | # toolbar - you may pass right to pack from the other 129 | # side. 130 | # 131 | # Results: 132 | # The name of the button being created. 133 | 134 | proc tool::createButton {but img txt cmd {side left}} { 135 | variable gui 136 | 137 | set but [button $but -image $img -command $cmd -relief flat \ 138 | -bd 1 -height [image height $img] -width [image width $img]] 139 | pack $but -side $side -pady 2 140 | 141 | gui::registerStatusMessage $but $txt 5 142 | tool::addButtonBindings $but 143 | 144 | return $but 145 | } 146 | 147 | # tool::addButtonBindings -- 148 | # 149 | # Add and bindings to the buttons so they raise and 150 | # lower as the mouse goes in and out of the button. This routine 151 | # should be called after the gui::registerStatusMessage to assure 152 | # the bindings are added in order. 153 | # 154 | # Arguments: 155 | # but The button to add the bindings to. 156 | # 157 | # Results: 158 | # None. 159 | 160 | proc tool::addButtonBindings {but} { 161 | bind $but {+ 162 | if {[%W cget -state] == "normal"} { 163 | %W config -relief raised 164 | } 165 | } 166 | bind $but {+ 167 | %W config -relief flat 168 | } 169 | } 170 | 171 | # tool::updateMessage -- 172 | # 173 | # Update the status message displayed based on the state of the debugger. 174 | # 175 | # Arguments: 176 | # state The new state of the debugger. 177 | # 178 | # Results: 179 | # None. 180 | 181 | proc tool::updateMessage {state} { 182 | variable tool 183 | 184 | # Override all of the and bindings and add the new 185 | # message to display for the help message. 186 | 187 | switch -exact -- $state { 188 | new - 189 | parseError - 190 | stopped - 191 | running { 192 | gui::registerStatusMessage $tool(run) \ 193 | {Run until break or EOF.} 5 194 | gui::registerStatusMessage $tool(into) \ 195 | {Step into the next procedure.} 5 196 | } 197 | dead { 198 | gui::registerStatusMessage $tool(run) \ 199 | {Start app and run until break or EOF.} 5 200 | gui::registerStatusMessage $tool(into) \ 201 | {Start app and step to first command.} 5 202 | } 203 | default { 204 | error "Unknown state \"$state\": in tool::updateMessage" 205 | } 206 | } 207 | 208 | # Now add the bindings that raise and lower the toolbar buttons. 209 | 210 | tool::addButtonBindings $tool(run) 211 | tool::addButtonBindings $tool(into) 212 | 213 | return 214 | } 215 | 216 | # tool::changeState -- 217 | # 218 | # Update the state of the Toolbar buttons. 219 | # 220 | # Arguments: 221 | # buttonList Names of the buttons to re-configure. 222 | # state The state all buttons in buttonList 223 | # will be configure to. 224 | # 225 | # Results: 226 | # None. 227 | 228 | proc tool::changeState {buttonList state} { 229 | variable tool 230 | 231 | foreach button $buttonList { 232 | switch $button { 233 | refreshFile - 234 | restart - 235 | run - 236 | stop - 237 | kill - 238 | inspector { 239 | $tool($button) configure -state $state 240 | tool::changeButtonState $button $state 241 | } 242 | stepIn { 243 | $tool(into) configure -state $state 244 | tool::changeButtonState into $state 245 | } 246 | stepOut { 247 | $tool(out) configure -state $state 248 | tool::changeButtonState out $state 249 | } 250 | stepOver { 251 | $tool(over) configure -state $state 252 | tool::changeButtonState over $state 253 | } 254 | stepTo { 255 | $tool(to) configure -state $state 256 | tool::changeButtonState to $state 257 | } 258 | stepResult { 259 | $tool(cmdresult) configure -state $state 260 | tool::changeButtonState cmdresult $state 261 | } 262 | showStack { 263 | $tool(stack) configure -state $state 264 | tool::changeButtonState stack $state 265 | } 266 | default { 267 | error "Unknown toolbar item \"$button\": in tool::changeState" 268 | } 269 | } 270 | } 271 | } 272 | 273 | # tool::changeButtonState -- 274 | # 275 | # Change the state of the button. 276 | # 277 | # Arguments: 278 | # but Name of the button. 279 | # state New state. 280 | # 281 | # Results: 282 | # None. 283 | 284 | proc tool::changeButtonState {but state} { 285 | variable tool 286 | 287 | if {$state == "disabled"} { 288 | $tool($but) configure -image $image::image(${but}_disable) 289 | } else { 290 | $tool($but) configure -image $image::image($but) 291 | } 292 | } 293 | 294 | 295 | -------------------------------------------------------------------------------- /src/tcl/lib/tcldebugger/uplevel.pdx: -------------------------------------------------------------------------------- 1 | # blend.pdx -- 2 | # 3 | # This file implements the TclPro Debugger extension for the 4 | # TclBlend extension. 5 | # 6 | # Copyright (c) 1998-2000 Ajuba Solutions 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | # Register the TclBlend extension 12 | 13 | instrument::addExtension 2.0 {parseUplevel} 14 | 15 | namespace eval parseUplevel { 16 | } 17 | 18 | # Register handlers for each of the TclBlend commands 19 | 20 | instrument::addCommand uplevel \ 21 | {parseSimpleArgs 1 -1 parseUplevel::parseUplevelCmd} 22 | 23 | # parseUplevel::parseUplevelCmd -- 24 | # 25 | # This routine wraps the foobar command. 26 | # Parse args of the pattern: 27 | # ?catch exception_pair script ... ? ?finally script? 28 | # 29 | # Arguments: 30 | # tokens The list of word tokens for the current command. 31 | # index The index of the next word to be parsed. 32 | # 33 | # Results: 34 | # Returns the index of the last token + 1 (all have been parsed). 35 | 36 | proc parseUplevel::parseUplevelCmd {tokens index} { 37 | set argc [expr {[llength $tokens] - $index}] 38 | 39 | if {$argc == 1} { 40 | return [instrument::parseSimpleArgs 1 1 {parseBody} $tokens $index] 41 | } elseif {$argc == 2} { 42 | instrument::getLiteral [lindex $tokens $index] literal 43 | if {[regexp {^\#?[0-9]+$} $literal]} { 44 | # If there's a literal level arg, call parseWord on it. 45 | 46 | return [instrument::parseSimpleArgs 2 2 {parseWord parseBody} \ 47 | $tokens $index] 48 | } 49 | } 50 | return [instrument::parseSimpleArgs 1 -1 {parseWord} $tokens $index] 51 | } 52 | -------------------------------------------------------------------------------- /src/tcl/lib/tcldebugger/util.tcl: -------------------------------------------------------------------------------- 1 | # util.tcl -- 2 | # 3 | # This file contains miscellaneous utilities. 4 | # 5 | # Copyright (c) 1998-2000 Ajuba Solutions 6 | # Copyright (c) 2017 Forward Folio LLC 7 | # See the file "license.terms" for information on usage and redistribution of this file. 8 | # 9 | 10 | # lassign -- 11 | # 12 | # This function emulates the TclX lassign command. 13 | # 14 | # Arguments: 15 | # valueList A list containing the values to be assigned. 16 | # args The list of variables to be assigned. 17 | # 18 | # Results: 19 | # Returns any values that were not assigned to variables. 20 | 21 | if {[info commands lassign] eq {}} { 22 | 23 | # start lassign proc 24 | proc lassign {valueList args} { 25 | if {[llength $args] == 0} { 26 | error "wrong # args: lassign list varname ?varname..?" 27 | } 28 | 29 | uplevel [list foreach $args $valueList {break}] 30 | return [lrange $valueList [llength $args] end] 31 | } 32 | # end lassign proc 33 | 34 | } 35 | 36 | # matchKeyword -- 37 | # 38 | # Find the unique match for a string in a keyword table and return 39 | # the associated value. 40 | # 41 | # Arguments: 42 | # table A list of keyword/value pairs. 43 | # str The string to match. 44 | # exact If 1, only exact matches are allowed, otherwise unique 45 | # abbreviations are considered valid matches. 46 | # varName The name of a variable that will hold the resulting value. 47 | # 48 | # Results: 49 | # Returns 1 on a successful match, else 0. 50 | 51 | proc matchKeyword {table str exact varName} { 52 | upvar $varName result 53 | if {$str == ""} { 54 | foreach pair $table { 55 | set key [lindex $pair 0] 56 | if {$key == ""} { 57 | set result [lindex $pair 1] 58 | return 1 59 | } 60 | } 61 | return 0 62 | } 63 | if {$exact} { 64 | set end end 65 | } else { 66 | set end [expr {[string length $str] - 1}] 67 | } 68 | set found "" 69 | foreach pair $table { 70 | set key [lindex $pair 0] 71 | if {[string compare $str [string range $key 0 $end]] == 0} { 72 | # If the string matches exactly, return immediately. 73 | 74 | if {$exact || ($end == ([string length $key]-1))} { 75 | set result [lindex $pair 1] 76 | return 1 77 | } else { 78 | lappend found [lindex $pair 1] 79 | } 80 | } 81 | } 82 | if {[llength $found] == 1} { 83 | set result [lindex $found 0] 84 | return 1 85 | } else { 86 | return 0 87 | } 88 | } 89 | 90 | -------------------------------------------------------------------------------- /src/tcl/lib/tcldebugger/varWin.tcl: -------------------------------------------------------------------------------- 1 | # varWin.tcl -- 2 | # 3 | # This file implements the Var Window (contained in the 4 | # main debugger window.) 5 | # 6 | # Copyright (c) 1998-2000 Ajuba Solutions 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | 12 | namespace eval var { 13 | # Handles to the text windows that display variable names 14 | # and values. 15 | 16 | variable valuText {} 17 | variable nameText {} 18 | variable vbpText {} 19 | } 20 | 21 | # var::createWindow -- 22 | # 23 | # Create the var window and all of the sub elements. 24 | # 25 | # Arguments: 26 | # masterFrm The frame that contains the var frame. 27 | # 28 | # Results: 29 | # The frame that contains the Var Window. 30 | 31 | proc var::createWindow {masterFrm} { 32 | variable nameText 33 | variable valuText 34 | variable vbpText 35 | 36 | array set bar [system::getBar] 37 | 38 | set varFrm [frame $masterFrm.varFrm] 39 | set nameFrm [frame $varFrm.nameFrm] 40 | set vbpFrm [frame $nameFrm.vbpFrm -width $bar(width)] 41 | set vbpText [text $vbpFrm.vbpTxt -width 1 -height 20 -bd 0 \ 42 | -bg $bar(color)] 43 | set nameText [text $nameFrm.nameTxt -width 20 -height 20 -bd 0] 44 | set valuFrm [frame $varFrm.valuFrm] 45 | set valuText [text $valuFrm.valuTxt -width 20 -height 20 -bd 0 \ 46 | -yscroll [list $valuFrm.sb set]] 47 | set sb [scrollbar $valuFrm.sb -command {watch::scrollWindow \ 48 | $var::nameText}] 49 | 50 | pack propagate $vbpFrm 0 51 | pack $vbpFrm -side left -fill y 52 | pack $vbpText -side left -fill both -expand true 53 | pack $nameText -side left -fill both -expand true 54 | grid $valuText -sticky wnse -row 0 -column 0 55 | grid columnconfigure $valuFrm 0 -weight 1 56 | grid rowconfigure $valuFrm 0 -weight 1 57 | guiUtil::tableCreate $varFrm $nameFrm $valuFrm \ 58 | -title1 "Variable" -title2 "Value" -percent 0.4 59 | 60 | # Create the mapping for Watch text widgets. See the 61 | # description of the text variable in the namespace eval 62 | # statement of watchWin.tcl. 63 | 64 | set watch::text(name,$nameText) $nameText 65 | set watch::text(name,$valuText) $nameText 66 | set watch::text(name,$vbpText) $nameText 67 | set watch::text(valu,$nameText) $valuText 68 | set watch::text(valu,$valuText) $valuText 69 | set watch::text(valu,$vbpText) $valuText 70 | set watch::text(vbp,$nameText) $vbpText 71 | set watch::text(vbp,$valuText) $vbpText 72 | set watch::text(vbp,$vbpText) $vbpText 73 | 74 | bind::addBindTags $valuText [list watchBind varDbgWin] 75 | bind::addBindTags $nameText [list watchBind varDbgWin] 76 | watch::internalBindings $nameText $valuText $vbpText $sb 77 | gui::registerStatusMessage $vbpText \ 78 | "Click in the bar to set a variable breakpoint" 79 | sel::setWidgetCmd $valuText all { 80 | watch::cleanupSelection $var::valuText 81 | var::checkState 82 | } { 83 | watch::seeCallback $var::valuText 84 | } 85 | 86 | bind varDbgWin <> { 87 | var::addToWatch 88 | } 89 | $valuText tag bind handle { 90 | set gui::afterStatus(%W) [after 2000 \ 91 | {gui::updateStatusMessage -msg \ 92 | "Click to expand or flatten the array"}] 93 | } 94 | $valuText tag bind handle { 95 | if {[info exists gui::afterStatus(%W)]} { 96 | after cancel $gui::afterStatus(%W) 97 | unset gui::afterStatus(%W) 98 | gui::updateStatusMessage -msg {} 99 | } 100 | } 101 | 102 | return $varFrm 103 | } 104 | 105 | # var::updateWindow -- 106 | # 107 | # Update the display of the Var window. This routine 108 | # expects the return of gui::getCurrentLevel to give 109 | # the level displayed in the Stack Window. 110 | # 111 | # Arguments: 112 | # None. 113 | # 114 | # Results: 115 | # None. 116 | 117 | proc var::updateWindow {} { 118 | variable nameText 119 | variable valuText 120 | variable vbpText 121 | 122 | if {[gui::getCurrentState] != "stopped"} { 123 | return 124 | } 125 | 126 | set level [gui::getCurrentLevel] 127 | set varList [lsort -dictionary -index 1 \ 128 | [watch::varDataAddVars $valuText $level]] 129 | 130 | # Call the internal routine that populates the var name and 131 | # var value windows. 132 | 133 | watch::updateInternal $nameText $valuText $vbpText $varList $level 134 | } 135 | 136 | # var::resetWindow -- 137 | # 138 | # Clear the contents of the window and display a 139 | # message in its place. 140 | # 141 | # Arguments: 142 | # msg If not null, then display the contents of the 143 | # message in the window. 144 | # 145 | # Results: 146 | # None. 147 | 148 | proc var::resetWindow {{msg {}}} { 149 | variable nameText 150 | variable valuText 151 | variable vbpText 152 | 153 | gui::unsetFormatData $nameText 154 | gui::unsetFormatData $valuText 155 | $nameText delete 0.0 end 156 | $valuText delete 0.0 end 157 | $vbpText delete 0.0 end 158 | 159 | if {$msg != {}} { 160 | $valuText insert 0.0 $msg message 161 | } 162 | } 163 | 164 | # var::checkState -- 165 | # 166 | # This proc is executed whenever the selection 167 | # in the Var Window changes. 168 | # 169 | # Arguments: 170 | # None. 171 | # 172 | # Results: 173 | # None. 174 | 175 | proc var::checkState {} { 176 | variable valuText 177 | 178 | if {[focus] == $valuText} { 179 | watch::changeFocus $valuText in 180 | } 181 | } 182 | 183 | # watch::addToWatch -- 184 | # 185 | # Add the selected variables to the Watch Window. 186 | # 187 | # Arguments: 188 | # None. 189 | # 190 | # Results: 191 | # None. 192 | 193 | proc var::addToWatch {} { 194 | variable valuText 195 | 196 | set lineList [sel::getSelectedLines $valuText] 197 | foreach line $lineList { 198 | set oname [watch::varDataGet $valuText $line.0 "oname"] 199 | watch::addVar $oname 200 | } 201 | } 202 | 203 | # var::seeVarInWindow -- 204 | # 205 | # Move the Var Window to show the variable that was selected 206 | # in the Stack Window. The Var Window is assumed to be updated 207 | # to the current frame and that the variable exists in the 208 | # frame. 209 | # 210 | # Arguments: 211 | # varName The name of the variable to be moved into 212 | # sight of the var window. 213 | # moveFocus Boolean value, if true move the focus to the 214 | # Var Window after the word is shown. 215 | # 216 | # Results: 217 | # None. 218 | 219 | proc var::seeVarInWindow {varName moveFocus} { 220 | variable nameText 221 | variable valuText 222 | 223 | # Build a list of line numbers, one foreach line in the 224 | # Var Window. The pass this to watch::getVarNames to 225 | # retrieve a list of all valid var names. 226 | 227 | set varNameList {} 228 | for {set i 1} {$i < [$var::nameText index end]} {incr i} { 229 | set oname [watch::varDataGet $valuText $i.0 "oname"] 230 | lappend varNameList [code::mangle $oname] 231 | } 232 | 233 | # Search the list of var names to see if the var exists in the 234 | # Var Window. If so select the line and possibly force the 235 | # focus to the Var WIndow. 236 | 237 | set line [expr {[lsearch $varNameList $varName] + 1}] 238 | if {$line >= 0} { 239 | watch::selectLine $nameText $line.0 240 | if {$moveFocus} { 241 | focus $valuText 242 | } 243 | } 244 | } 245 | -------------------------------------------------------------------------------- /src/tcl/lib/tcldebugger/xmlGen.pdx: -------------------------------------------------------------------------------- 1 | # xmlGen.pdx -- 2 | # 3 | # This file implements the TclPro Debugger extension for the XML 4 | # Generation API. 5 | # 6 | # Copyright (c) 1998-2000 Ajuba Solutions 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | # Register the XML Generation extension 12 | 13 | instrument::addExtension 2.0 {xmlGen} 14 | 15 | # Register handlers for each of the XML Generation commands 16 | 17 | instrument::addCommand element {parseSimpleArgs 2 4 { 18 | parseWord parseWord parseWord parseBody}} 19 | instrument::addCommand xmlgen::element {parseSimpleArgs 2 4 { 20 | parseWord parseWord parseWord parseBody}} 21 | -------------------------------------------------------------------------------- /src/tcl/tclDebug.tcl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env tclsh 2 | 3 | # 4 | # Copyright (c) FlightAware 2018. All rights reserved 5 | # Licensed under the MIT License. See License.txt for license information 6 | # 7 | 8 | package require yajltcl 9 | package require Tclx 10 | 11 | set runDir [file dirname [info script]] 12 | source [file join $runDir debugger.tcl] 13 | 14 | set ::response_seq 1 15 | 16 | proc parse_header {header} { 17 | set header [regsub {:} $header {}] 18 | if {[llength $header] != 2} { 19 | error "header should consist of key/value, llength = 2, but does not" 20 | } 21 | return [lindex $header 1] 22 | } 23 | 24 | proc check_arguments {_request} { 25 | upvar $_request request 26 | if {![info exists request(arguments)]} { 27 | error "request is missing required arguments" 28 | } 29 | } 30 | 31 | proc create_response {seq command _body} { 32 | global response_seq 33 | upvar $_body body 34 | 35 | yajl create doc 36 | doc map_open string seq integer $response_seq \ 37 | string type string response \ 38 | string request_seq integer $seq \ 39 | string success bool true \ 40 | string command string $command \ 41 | string body map_open 42 | 43 | foreach {key value} [array get body] { 44 | set type string 45 | if {$key eq "breakpoints"} { 46 | doc string breakpoints array_open 47 | foreach {line verified} $value { 48 | doc map_open string line integer $line string verified bool $verified map_close 49 | } 50 | doc array_close 51 | continue 52 | } 53 | if {$key eq "threads"} { 54 | doc string threads array_open 55 | foreach {id name} $value { 56 | doc map_open string id integer $id string name string $name map_close 57 | } 58 | doc array_close 59 | continue 60 | } 61 | if {$key eq "stackTrace"} { 62 | doc string stackFrames array_open 63 | set stacks 0 64 | foreach stack [lreverse $value] { 65 | lassign $stack level loc type args 66 | # if {$level != 0} { 67 | doc map_open string id integer $level \ 68 | string name string [expr {$type eq "global" ? $type : $args}] \ 69 | string line integer [expr {$loc ne {} ? [loc::getLine $loc] : 0}] \ 70 | string column integer 0 71 | if {$type eq "source"} { 72 | doc string source map_open string path string $args map_close 73 | } elseif {$type eq "proc"} { 74 | set source [blk::getFile [loc::getBlock $loc]] 75 | doc string source map_open string path string $source map_close 76 | } 77 | doc map_close 78 | incr stacks 79 | # } 80 | } 81 | doc array_close string totalFrames integer $stacks 82 | continue 83 | } 84 | if {$key eq "scopes"} { 85 | lassign $value level loc type args 86 | set name [expr {$type eq "proc" ? "Locals" : "Globals"}] 87 | doc string scopes array_open \ 88 | map_open string name string $name \ 89 | string variablesReference integer [expr {$level + 1}] \ 90 | string namedVariables integer [llength [dbg::getVariables $level]] \ 91 | string expensive bool false \ 92 | map_close array_close 93 | continue 94 | } 95 | if {$key eq "variables"} { 96 | set level [expr {$value - 1}] 97 | foreach var [dbg::getVariables $level] { 98 | lappend vars [lindex $var 0] 99 | } 100 | doc string variables array_open 101 | foreach var [dbg::getVar $level -1 $vars] { 102 | lassign $var varName type varValue 103 | doc map_open string name string $varName \ 104 | string value string $varValue \ 105 | string type string [expr {$type eq "a" ? "array" : "string"}] \ 106 | string variablesReference integer 0 \ 107 | map_close 108 | } 109 | doc array_close 110 | continue 111 | } 112 | if {[string is integer -strict $value]} { 113 | set type integer 114 | } elseif {[string is boolean -strict $value]} { 115 | set type bool 116 | } 117 | doc string $key $type $value 118 | } 119 | 120 | doc map_close map_close 121 | set response [doc get] 122 | doc delete 123 | incr ::response_seq 124 | return $response 125 | } 126 | 127 | proc create_stopped_event {reason description threadId} { 128 | global response_seq 129 | 130 | yajl create doc 131 | doc map_open string seq integer $response_seq \ 132 | string type string event \ 133 | string event string stopped \ 134 | string body map_open \ 135 | string reason string $reason \ 136 | string description string $description \ 137 | string threadId integer $threadId \ 138 | map_close map_close 139 | set event [doc get] 140 | doc delete 141 | incr ::response_seq 142 | return $event 143 | } 144 | 145 | proc send_terminate_event {} { 146 | global response_seq 147 | 148 | yajl create doc 149 | doc map_open string seq integer $response_seq \ 150 | string type string event \ 151 | string event string terminated \ 152 | string body map_open \ 153 | map_close map_close 154 | set event [doc get] 155 | doc delete 156 | incr ::response_seq 157 | transmit_data $event 158 | } 159 | 160 | proc send_exit_event {args} { 161 | global response_seq 162 | 163 | yajl create doc 164 | doc map_open string seq integer $response_seq \ 165 | string type string event \ 166 | string event string exited \ 167 | string body map_open \ 168 | string exitCode integer 0 \ 169 | map_close map_close 170 | set event [doc get] 171 | doc delete 172 | incr ::response_seq 173 | transmit_data $event 174 | } 175 | 176 | proc error_response {seq command message} { 177 | yajl create doc 178 | doc map_open string seq integer $::response_seq \ 179 | string type string response \ 180 | string request_seq integer $seq \ 181 | string success bool false \ 182 | string message string $message \ 183 | map_close 184 | set errorResponse [doc get] 185 | doc delete 186 | incr ::response_seq 187 | return $errorResponse 188 | } 189 | 190 | proc send_capabilities {seq} { 191 | set body(supportsConfigurationDoneRequest) true 192 | # set body(supportsSetVariable) true 193 | # set body(supportsFunctionBreakpoints) true 194 | set body(supportsTerminateRequest) true 195 | 196 | transmit_data [create_response $seq initialize body] 197 | return 0 198 | } 199 | 200 | proc send_initialized {} { 201 | yajl create doc 202 | doc map_open string seq integer $::response_seq string type string event string event string initialized map_close 203 | set event [doc get] 204 | doc delete 205 | incr ::response_seq 206 | transmit_data $event 207 | return 0 208 | } 209 | 210 | proc parse_initialize {_args seq} { 211 | upvar $_args args 212 | set ::columnsStartAt1 [string is true -strict $args(linesStartAt1)] 213 | set ::linesStartAt1 [string is true -strict $args(columnsStartAt1)] 214 | set ::locale $args(locale) 215 | set ::projName $args(clientID) 216 | 217 | send_capabilities $seq 218 | send_initialized 219 | return 0 220 | } 221 | 222 | proc launch_debugger {_args seq} { 223 | global fh 224 | upvar $_args args 225 | 226 | if {![info exists args(program)]} { 227 | transmit_data [error_response $seq launch "Launch request missing program"] 228 | return 229 | } 230 | if {![info exists args(args)]} { 231 | transmit_data [error_response $seq launch "Launch request missing script arguments"] 232 | return 233 | } 234 | 235 | set debugVars(interp) "/usr/local/bin/tclsh" 236 | set debugVars(dir) {} 237 | set debugVars(script) $args(program) 238 | set debugVars(scriptArgs) $args(args) 239 | set debugVars(projName) $::projName 240 | set startCmd [expr {[info exists args(stopOnEntry)] && $args(stopOnEntry) ? "dbg::step" : "dbg::run"}] 241 | 242 | if {[catch { 243 | ::debugger::setDebugVars [array get debugVars] 244 | ::debugger::init 245 | ::debugger::start $startCmd 246 | } err] == 1} { 247 | transmit_data [error_response $seq launch "$err\ntrace: $errorInfo"] 248 | return 249 | } 250 | 251 | set ::launch_seq $seq 252 | return 0 253 | } 254 | 255 | proc transmit_data {msg} { 256 | global fh 257 | 258 | set res "Content-Length: [string length $msg]\r\n\r\n$msg" 259 | puts $fh $res 260 | flush $fh 261 | puts $res 262 | return 0 263 | } 264 | 265 | proc parse_content {content} { 266 | set request [::yajl::json2dict $content] 267 | if {![dict exists $request type] || ![dict exists $request seq]} { 268 | error "message is lacking required field type or seq" 269 | } 270 | set seq [dict get $request seq] 271 | switch [dict get $request type] { 272 | request { 273 | if {![dict exists $request command]} { 274 | error "request message is lacking required field command" 275 | } 276 | set command [dict get $request command] 277 | switch $command { 278 | initialize { 279 | array set arguments [dict get $request arguments] 280 | parse_initialize arguments $seq 281 | } 282 | launch { 283 | array set arguments [dict get $request arguments] 284 | launch_debugger arguments $seq 285 | } 286 | setBreakpoints { 287 | array set arguments [dict get $request arguments] 288 | vwait ::debuggerReady 289 | set body(breakpoints) [debugger::setBreakpoints arguments] 290 | transmit_data [create_response $seq $command body] 291 | } 292 | setExceptionBreakpoints { 293 | transmit_data [create_response $seq $command {}] 294 | } 295 | configurationDone { 296 | transmit_data [create_response $seq $command {}] 297 | } 298 | threads { 299 | set body(threads) {1 main} 300 | transmit_data [create_response $seq $command body] 301 | if {[info exists ::launch_seq]} { 302 | transmit_data [create_response $::launch_seq launch {}] 303 | unset -nocomplain ::launch_seq 304 | debugger::run run 305 | } 306 | } 307 | stackTrace { 308 | set body(stackTrace) [dbg::getStack] 309 | transmit_data [create_response $seq $command body] 310 | } 311 | scopes { 312 | set stacks [dbg::getStack] 313 | set frameId [dict get $request arguments frameId] 314 | set stackIndex [lsearch -index 0 $stacks $frameId] 315 | set body(scopes) [lindex $stacks $stackIndex] 316 | transmit_data [create_response $seq $command body] 317 | } 318 | variables { 319 | set body(variables) [dict get $request arguments variablesReference] 320 | transmit_data [create_response $seq $command body] 321 | } 322 | continue { 323 | debugger::run run 324 | transmit_data [create_response $seq $command {}] 325 | } 326 | next { 327 | debugger::run over 328 | transmit_data [create_response $seq $command {}] 329 | } 330 | terminate { 331 | transmit_data [create_response $seq $command {}] 332 | debugger::exitHandler 333 | } 334 | } 335 | } 336 | } 337 | return 0 338 | } 339 | 340 | proc debugger_linebreak {args} { 341 | if {[info exists ::launch_seq]} { 342 | set ::debuggerReady 1 343 | return 344 | } 345 | transmit_data [create_stopped_event breakpoint "Paused at breakpoint" 1] 346 | } 347 | 348 | proc shutdown {} { 349 | set ::die 1 350 | } 351 | 352 | proc getReadable { f } { 353 | global fh 354 | set status [catch {gets $f line} result] 355 | if {$status != 0 } { 356 | puts stderr "Error reading stdin" 357 | set ::die 1 358 | } elseif {$result >= 0} { 359 | puts $fh "line: $line" 360 | flush $fh 361 | if {[catch {parse_header $line} bytes] == 1} { 362 | puts $fh "Error: $bytes" 363 | flush $fh 364 | } else { 365 | set content [read stdin [expr {$bytes + 1}]] 366 | set content [string trim $content] 367 | puts $fh $content 368 | flush $fh 369 | if {[catch {parse_content $content} res] == 1} { 370 | puts $fh "Error with parse_content: $res" 371 | } 372 | flush $fh 373 | } 374 | } elseif { [fblocked $f] } { 375 | return 376 | } else { 377 | puts stderr "something wrong with stdin" 378 | set ::die 1 379 | } 380 | } 381 | 382 | proc main {argv} { 383 | global fh 384 | signal trap SIGINT shutdown 385 | signal trap SIGTERM shutdown 386 | 387 | set fh [open "/tmp/out.log" w] 388 | 389 | debugger::register linebreak debugger_linebreak 390 | 391 | fconfigure stdin -blocking false 392 | fileevent stdin readable [list getReadable stdin] 393 | 394 | vwait ::die 395 | 396 | puts $fh "exiting" 397 | close $fh 398 | } 399 | 400 | if {!$tcl_interactive} { 401 | main $argv 402 | } -------------------------------------------------------------------------------- /src/tcl/test_debugger.tcl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env tclsh 2 | 3 | set debugVars(interp) "/usr/local/bin/tclsh" 4 | set debugVars(dir) {} 5 | set debugVars(script) "/Users/jonathan.cone/dev/mock_debug/test.tcl" 6 | set debugVars(scriptArgs) "" 7 | set debugVars(projName) "vscode" 8 | set startCmd "dbg::step" 9 | 10 | source debugger.tcl 11 | debugger::setDebugVars [array get debugVars] 12 | debugger::init 13 | debugger::start $startCmd 14 | vwait forever 15 | -------------------------------------------------------------------------------- /src/tests/adapter.test.ts: -------------------------------------------------------------------------------- 1 | /*--------------------------------------------------------------------------------------------- 2 | * Copyright (c) Microsoft Corporation. All rights reserved. 3 | * Licensed under the MIT License. See License.txt in the project root for license information. 4 | *--------------------------------------------------------------------------------------------*/ 5 | 6 | import assert = require('assert'); 7 | import * as Path from 'path'; 8 | import {DebugClient} from 'vscode-debugadapter-testsupport'; 9 | import {DebugProtocol} from 'vscode-debugprotocol'; 10 | 11 | suite('Node Debug Adapter', () => { 12 | 13 | const DEBUG_ADAPTER = './out/debugAdapter.js'; 14 | 15 | const PROJECT_ROOT = Path.join(__dirname, '../../'); 16 | const DATA_ROOT = Path.join(PROJECT_ROOT, 'src/tests/data/'); 17 | 18 | 19 | let dc: DebugClient; 20 | 21 | setup( () => { 22 | dc = new DebugClient('node', DEBUG_ADAPTER, 'mock'); 23 | return dc.start(); 24 | }); 25 | 26 | teardown( () => dc.stop() ); 27 | 28 | 29 | suite('basic', () => { 30 | 31 | test('unknown request should produce error', done => { 32 | dc.send('illegal_request').then(() => { 33 | done(new Error("does not report error on unknown request")); 34 | }).catch(() => { 35 | done(); 36 | }); 37 | }); 38 | }); 39 | 40 | suite('initialize', () => { 41 | 42 | test('should return supported features', () => { 43 | return dc.initializeRequest().then(response => { 44 | response.body = response.body || {}; 45 | assert.equal(response.body.supportsConfigurationDoneRequest, true); 46 | }); 47 | }); 48 | 49 | test('should produce error for invalid \'pathFormat\'', done => { 50 | dc.initializeRequest({ 51 | adapterID: 'mock', 52 | linesStartAt1: true, 53 | columnsStartAt1: true, 54 | pathFormat: 'url' 55 | }).then(response => { 56 | done(new Error("does not report error on invalid 'pathFormat' attribute")); 57 | }).catch(err => { 58 | // error expected 59 | done(); 60 | }); 61 | }); 62 | }); 63 | 64 | suite('launch', () => { 65 | 66 | test('should run program to the end', () => { 67 | 68 | const PROGRAM = Path.join(DATA_ROOT, 'test.md'); 69 | 70 | return Promise.all([ 71 | dc.configurationSequence(), 72 | dc.launch({ program: PROGRAM }), 73 | dc.waitForEvent('terminated') 74 | ]); 75 | }); 76 | 77 | test('should stop on entry', () => { 78 | 79 | const PROGRAM = Path.join(DATA_ROOT, 'test.md'); 80 | const ENTRY_LINE = 1; 81 | 82 | return Promise.all([ 83 | dc.configurationSequence(), 84 | dc.launch({ program: PROGRAM, stopOnEntry: true }), 85 | dc.assertStoppedLocation('entry', { line: ENTRY_LINE } ) 86 | ]); 87 | }); 88 | }); 89 | 90 | suite('setBreakpoints', () => { 91 | 92 | test('should stop on a breakpoint', () => { 93 | 94 | const PROGRAM = Path.join(DATA_ROOT, 'test.md'); 95 | const BREAKPOINT_LINE = 2; 96 | 97 | return dc.hitBreakpoint({ program: PROGRAM }, { path: PROGRAM, line: BREAKPOINT_LINE } ); 98 | }); 99 | 100 | test('hitting a lazy breakpoint should send a breakpoint event', () => { 101 | 102 | const PROGRAM = Path.join(DATA_ROOT, 'testLazyBreakpoint.md'); 103 | const BREAKPOINT_LINE = 3; 104 | 105 | return Promise.all([ 106 | 107 | dc.hitBreakpoint({ program: PROGRAM }, { path: PROGRAM, line: BREAKPOINT_LINE, verified: false } ), 108 | 109 | dc.waitForEvent('breakpoint').then((event : DebugProtocol.BreakpointEvent ) => { 110 | assert.equal(event.body.breakpoint.verified, true, "event mismatch: verified"); 111 | }) 112 | ]); 113 | }); 114 | }); 115 | 116 | suite('setExceptionBreakpoints', () => { 117 | 118 | test('should stop on an exception', () => { 119 | 120 | const PROGRAM_WITH_EXCEPTION = Path.join(DATA_ROOT, 'testWithException.md'); 121 | const EXCEPTION_LINE = 4; 122 | 123 | return Promise.all([ 124 | 125 | dc.waitForEvent('initialized').then(event => { 126 | return dc.setExceptionBreakpointsRequest({ 127 | filters: [ 'all' ] 128 | }); 129 | }).then(response => { 130 | return dc.configurationDoneRequest(); 131 | }), 132 | 133 | dc.launch({ program: PROGRAM_WITH_EXCEPTION }), 134 | 135 | dc.assertStoppedLocation('exception', { line: EXCEPTION_LINE } ) 136 | ]); 137 | }); 138 | }); 139 | }); -------------------------------------------------------------------------------- /src/tests/data/test.md: -------------------------------------------------------------------------------- 1 | line 1 2 | line 2 3 | line 3 4 | line 4 5 | line 5 -------------------------------------------------------------------------------- /src/tests/data/testLazyBreakpoint.md: -------------------------------------------------------------------------------- 1 | line 1 2 | line 2 3 | line 3 lazy 4 | line 4 5 | line 5 -------------------------------------------------------------------------------- /src/tests/data/testWithException.md: -------------------------------------------------------------------------------- 1 | line 1 2 | line 2 3 | line 3 4 | line 4 with exception 5 | line 5 -------------------------------------------------------------------------------- /src/tsconfig.json: -------------------------------------------------------------------------------- 1 | { 2 | "compilerOptions": { 3 | "module": "commonjs", 4 | "target": "es6", 5 | 6 | "noImplicitAny": false, 7 | "removeComments": false, 8 | "noUnusedLocals": true, 9 | "noImplicitThis": true, 10 | "inlineSourceMap": false, 11 | "sourceMap": true, 12 | "outDir": "../out", 13 | "preserveConstEnums": true, 14 | "strictNullChecks": true, 15 | "noUnusedParameters": false 16 | } 17 | } 18 | -------------------------------------------------------------------------------- /src/tslint.json: -------------------------------------------------------------------------------- 1 | { 2 | "rules": { 3 | "no-unused-expression": true, 4 | "no-duplicate-variable": true, 5 | "curly": true, 6 | "class-name": true, 7 | "semicolon": [ "always" ], 8 | "triple-equals": true, 9 | "no-var-keyword": true, 10 | "no-bitwise": true 11 | } 12 | } --------------------------------------------------------------------------------