-
Notifications
You must be signed in to change notification settings - Fork 1
/
Copy pathddt.tcl
1403 lines (1223 loc) · 46.1 KB
/
ddt.tcl
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
##########################################################################
# DDT - Dynamic Debugging for Tcl
##########################################################################
# ddt.tcl - DDT's main package
#
# DDT provides all the necessary functionalities to perform dynamic
# debugging of Tcl programs.
#
# Copyright (C) 2014 Andreas Drollinger
##########################################################################
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
##########################################################################
# Title: DDT - Dynamic Debugging for Tcl
# This package provides dynamic debugging support for Tcl 8.5 or higher. It
# provides mainly commands to run Tcl files or scripts and to step through them,
# to define breakpoints, and to access variables in the context of the debugged
# code.
#
# DDT instrumentalizes the debugged code by inserting debugging helper
# commands. This is transparent (=invisible) to the user except he checks the
# procedure bodies for example with 'info body'. DDT uses the "unsupported"
# disassemble function of Tcl 8.5 and 8.6 to analyse the code to debug, to
# identify potential program execution stop locations.
# SubTitle: Dynamic Debugging for Tcl
# Footer: DDT - Dynamic Debugging for Tcl
# Create the ddt namespace.
namespace eval ::ddt {}
# This is the following DDT version:
variable ddt::version 0.1.0
# Specify the DDT version that is provided by this file:
package provide ddt $ddt::version
################ API ################
# Group: API
# DDT exposes the following API commands.
##########################
# Proc: ddt::Configure
# Configure DDT, or return the current configuration. If no argument is
# provided the current configuration is returned. If a single argument
# referring a configuration parameter is provided the configuration for
# this parameter is returned. Pairs of parameter names and values need
# to be provided if a new configuration needs to be defined. The
# available configurations are described in section <Configuration>.
#
# Parameters:
# [args] - Configuration definition list
#
# Returns:
# Returns the configuration if no new configuration is defined
#
# Examples:
# > ddt::Configure -BreakCallback DebugGuiUpdate
# > ddt::Configure -InitVars {argv0 {} argv {}} -InitScript "package require Tk"
# > ddt::Configure -Mode disable
#
# See also:
# <Configuration>
##########################
proc ddt::Configure {args} {
variable Config
switch -- [llength $args] {
0 {return [array get Config]}
1 {return $Config($args)}
default {array set Config $args; return}
}
}
##########################
# Proc: ddt::Run
# Starts the execution of a file or of a script. If breakpoints are
# defined the debug environment is initialized. If the configuration
# *-SI* is set the file or script is executed by a slave interpreter that
# is created.
#
# The two arguments allow using this command in 2 ways.
# * A file is provided but not a script: The file is executed.
# * A file and a script is provided. The script is executed. The file
# name is just used as identifier.
#
# Parameters:
# FileName - File name (can also be a fictitious identifier)
# [Script] - If provided this script will be executed
#
# Returns:
# Result returned by the file/script
#
# See Also:
# <ddt::Cont>, <ddt::Step>, <ddt::Stop>, <ddt::SetBP>
##########################
proc ddt::Run {FileName {Script {}}} {
variable ExecState
variable Config
variable BP
variable SI
# Check the current program execution state, and quit this procedure if
# an execution is ongoing.
if {$ExecState!=""} return
# Variable declaration and initialization
variable SourceFiles
variable SourceIScript
variable ExecLineNbr -1
set ExecState "cont"
set ExecFile $FileName
# No breakpoints are defined: Perform a normal execution of a script or
# a file (without providing debug support):
if {[array size BP]==0 || $Config(-Mode)!="enable"} {
# Initialize the run environment without debug support
RunEnvironment_Init 0
# Execute either the file or the script, either in the main
# interpreter or in a slave interpreter
if {$SI=={} && $Script=={}} {
set ResultCode [catch {uplevel #0 source \{$FileName\}} Result]
} elseif {$SI=={} && $Script!={}} {
set ResultCode [catch {uplevel #0 $Script} Result]
} elseif {$SI!={} && $Script!={}} {
set ResultCode [catch {interp eval $SI source \{$FileName\}} Result]
} elseif {$SI!={} && $Script!={}} {
set ResultCode [catch {interp eval $SI $Script} Result]
}
# Breakpoints are defined: Perform the execution of a script or a file in
# debug mode:
} else {
# Instrumentalize the file/script
variable ExecSourceId [Instrumentalize $FileName $Script]
# Initialize the run environment
RunEnvironment_Init 1
RunEnvironment_Resume
interp eval $SI "set ::ddt::CurrentSourcedFile \"$FileName\""
# Execute the instrumentalized script
if {$SI=={}} {
set ResultCode [catch {uplevel #0 $SourceIScript($ExecSourceId)} Result]
} else {
set ResultCode [catch {interp eval $SI $SourceIScript($ExecSourceId)} Result]
}
set ExecFile [lindex $SourceFiles $ExecSourceId]; # Recover the last executed file
}
# Destroy the run environment
RunEnvironment_Distroy
# Depending the execution result, call the call back command either with
# the 'error' or the 'ended' argument:
if {$ResultCode && $ExecState!="stop"} {
set ExecState ""
#uplevel #0 $Config(-BreakCallback) error \{$ExecFile\} $ExecLineNbr
eval $Config(-BreakCallback) error \{$ExecFile\} $ExecLineNbr
} else {
set ExecState ""
#uplevel #0 $Config(-BreakCallback) ended \{$ExecFile\} $ExecLineNbr
eval $Config(-BreakCallback) ended \{$ExecFile\} $ExecLineNbr
set Result ""
}
return $Result
}
##########################
# Proc: ddt::Cont
# Continues the execution of the program that is stopped on a breakpoint.
#
# Returns:
# Returns always the execution state 'cont'.
#
# See Also:
# <ddt::Run>, <ddt::Step>, <ddt::Stop>, <ddt::SetBP>
##########################
proc ddt::Cont {} {
variable ExecState
if {$ExecState==""} return
set ExecState "cont"
}
##########################
# Proc: ddt::Step
# Performs a single step in a program that is stopped on a breakpoint.
#
# Returns:
# Returns always the execution state 'step'.
#
# See Also:
# <ddt::Run>, <ddt::Cont>, <ddt::Stop>, <ddt::SetBP>
##########################
proc ddt::Step {} {
variable ExecState
if {$ExecState==""} return
set ExecState "step"
}
##########################
# Proc: ddt::Refresh
# Forces the callback function to be re-executed. A refresh of the
# application UI's status can be forced in this way.
#
# Returns:
# Returns always the execution state 'refresh'.
##########################
proc ddt::Refresh {} {
variable ExecState
if {$ExecState==""} return
set ExecState "refresh"
}
##########################
# Proc: ddt::Stop
# Stops the execution of a program that is currently either running or
# stopped on a breakpoint.
#
# Returns:
# Returns always the execution state 'stop'.
#
# See Also:
# <ddt::Run>, <ddt::Cont>, <ddt::Step>, <ddt::SetBP>
##########################
proc ddt::Stop {} {
variable ExecState
set ExecState "stop"
}
##########################
# Proc: ddt::Eval
# Evaluates a command sequence in the context of the executed procedure
# of the debugged program. Returns the result of the command sequence.
# This command can be used by the callback function to inspect the status
# of the debugged program or procedure. However, this command cannot be
# used by functions that are interactively executed (e.g. via buttons).
#
# Parameters:
# args - Command sequence
#
# Returns:
# Result returned by the command sequence, or any error generated by it
#
# See Also:
# <ddt::Exec>
##########################
proc ddt::Eval {args} {
variable SI
# A slave interpreter is used: Evaluate the command sequence via
# 'interp eval'
if {$SI!={}} {
set Code [catch {interp eval $SI $args} Result]
# No slave interpreter is used: Evaluate the stack level of a known
# command (e.g. ddt::Brk), and execute the command sequence a level
# below (witch is in the currently debugged program/procedure).
# ToDo: Check also for ddt::Run
} else {
# Evaluate the level of the procedure that is currently debugged
# Example:
# Level 0: ::ddt::Eval ... (this is this eval function)
# Level 1: ::Position break ... (this is the callback function)
# Level 2: ::ddt::Brk 0 9 1 ... (this is the Brk function that should be recognized)
# Level 3: MyDebuggedFunction . (this is the function that is debugged)
# Try just evaluating the command in level 3 if the break level cannot
# be found.
set BrkLevel 2
catch {
for {set Bl 2} {1} {incr Bl} {
if {[lindex [info level -$Bl] 0]=="::ddt::Brk"} {
set BrkLevel Bl
}
}
}
set Code [catch {uplevel 3 $args} Result]
}
return -code $Code $Result
}
##########################
# Proc: ddt::Exec
# Evaluates a command sequence in the context of the executed procedure
# of the debugged program. Returns always an empty string.
# This command can be used by the callback function as well as by a
# function that is interactively executed (e.g. via buttons).
#
# Parameters:
# args - Command sequence
#
# Returns:
# -
#
# See Also:
# <ddt::Eval>
##########################
proc ddt::Exec {args} {
variable SI
# A slave interpreter is used: Evaluate the command sequence via
# 'interp eval'
if {$SI!={}} {
interp eval $SI $args
# No slave interpreter is used: Force returning to the ddt::Brk procedure
# to execute the command sequence in the context of the debugged
# procedure/program.
} else {
# Define the code sequence, and set ExecState to 'exec': This will
# make ddt:Brk executing the code sequence.
variable ExecCmd [concat {*}$args]
variable ExecState "exec"
}
return
}
##########################
# Proc: ddt::SetBP
# Set or delete a breakpoint in a specified file at a specified line. If
# no condition is explicitly specified, or if the condition is 1, a non
# conditional breakpoint is defined. If the condition is 0 or '' an
# eventually defined breakpoint is deleted. The provided condition will
# be used in all other cases as a dynamic breakpoint condition.
#
# Parameters:
# FileName - File to apply the breakpoint definitions
# LineNbr - Line to which the breakpoint definition
# [Condition] - Optional condition
#
# Returns:
# Returns the new breakpoint condition
#
# See Also:
# <ddt::GetBP>, <ddt::SwapBP>
##########################
proc ddt::SetBP {FileName LineNbr {Condition 1}} {
variable BP
set SrcId [GetSourceId $FileName]
# Delete an eventual breakpoint if the condition is 0 or '':
if {$Condition=="0" || $Condition==""} {
array unset BP $SrcId,$LineNbr
return 0
# Store otherwise the breakpoint condition (this includes also hard
# breakpoints):
} else {
set BP($SrcId,$LineNbr) $Condition
return $Condition
}
}
##########################
# Proc: ddt::GetBP
# Returns for a specified file the breakpoint definitions. If no line is
# specified GetBP returns for all breakpoint for the file, otherwise only
# the ones for the specified line. The returned breakpoint definitions
# is a list composed by pairs of line numbers and breakpoint conditions.
#
# Parameters:
# FileName - File for which the breakpoint definitions have to be
# returned
# [LineNbr] - If defined only the breakpoint definitions are returned
# only for this line
#
# Returns:
# Breakpoint definition list
#
# See Also:
# <ddt::SetBP>, <ddt::SwapBP>
##########################
proc ddt::GetBP {FileName {LineNbr ""}} {
variable BP
set SrcId [GetSourceId $FileName]
# Line number is specified: Return 0 if no breakpoint is specified.
# Return the breakpoint condition otherwise.
if {$LineNbr!=""} {
if {[info exists BP($SrcId,$LineNbr)]} {
return $BP($SrcId,$LineNbr)
} else {
return 0
}
# Line number is not specified: Return a list of line numbers/breakpoint
# conditions for the specified file.
} else {
set LineNbrList {}
foreach BpIdx [array names BP $SrcId,*] {
regexp {,(\d+)$} $BpIdx {} LineNbr; # Extract the line number from the break point array index
lappend LineNbrList [list $LineNbr $BP($BpIdx)]
}
return $LineNbrList
}
}
##########################
# Proc: ddt::SwapBP
# Swaps a breakpoint in a specified line of a specified file. If no
# breakpoint (conditional or non conditional) exists, a non conditional
# breakpoint will be created. Otherwise the existing breakpoint will be
# deleted.
#
# Parameters:
# FileName - File for which the breakpoint definitions needs to be applied
# LineNbr - Line for which the breakpoint definition needs to be applied
#
# Returns:
# Returns the new breakpoint condition
#
# See Also:
# <dt::GetBP>, <dt::SetBP>
##########################
proc ddt::SwapBP {FileName LineNbr} {
SetBP $FileName $LineNbr [expr {[GetBP $FileName $LineNbr]=="0"}]
}
##########################
# Proc: ddt::GetBPLocations
# Returns for a specified file the possible breakpoint locations. If a
# line is specified GetBPLocations returns the breakpoint locations just
# for this line.
#
# Parameters:
# FileName - File for which the breakpoint locations have to be returned
# [LineNbr] - If defined: Line for which the breakpoint locations have to
# be returned
#
# Returns:
# Breakpoint location list
##########################
proc ddt::GetBPLocations {FileName {LineNbr ""}} {
variable BP
set SrcId [GetSourceId $FileName]
if {$LineNbr==""} {
return $::ddt::CommandPosListRC($SrcId)
} else {
return [lsearch -all -inline -exact -integer -index 0 $::ddt::CommandPosListRC($SrcId) $LineNbr]
}
}
##########################
# Proc: ddt::GetExecState
# Returns the execution state of the currently debugged file or script.
# The following states exist:
# * "" (initialization state)
# * cont (continuous running)
# * step (single instruction execution)
# * stop (stop request)
# * refresh (refresh request),
# * exec (command sequence execution request)
# * stopped (state while the Brk instruction is executed)
#
# Returns:
# Returns the current execution state.
##########################
proc ddt::GetExecState {} {
variable ExecState
return $ExecState
}
################ Configuration ################
# Group: Configuration
# DDT is configured via the <ddt::Configure> command. The configuration is
# stored by DDT inside the *Config* array variable. DDT uses the following
# configurations:
# Var: ddt::Config(-BreakCallback)
# Callback function configuration. Defines the callback function that
# will be called each time the execution of the debugged program is
# stopped.
#
# Example:
# > ddt::Configure -BreakCallback DebugGuiUpdate
set ddt::Config(-BreakCallback) ""
# Var: ddt::Config(-UseSI)
# Slave interpreter setting. If set to 1 (default) a slave interpreter
# will be used, if set to 0 the master interpreter will be used.
#
# Example:
# > ddt::Configure -UseSI 1
set ddt::Config(-UseSI) 1
# Var: ddt::Config(-InitVars)
# Initialization variable definition. The variable initializations, defined
# as pairs of variable names/values, will be executed in the context of
# the debugged program prior to the program start.
#
# Example:
# > ddt::Configure -InitVars {argv0 "" argv ""}
set ddt::Config(-InitVars) {}
# Var: ddt::Config(-InitScript)
# Initialization script. The defined script will be executed in the
# context of the debugged program prior to the program start.
#
# Example:
# > ddt::Configure -InitScript {}
set ddt::Config(-InitScript) {}
# Var: ddt::Config(-Mode)
# Enables/disables debugging. Valid settings are 'enable' (default), and
# 'disable'.
#
# Example:
# > ddt::Configure -Mode enable
set ddt::Config(-Mode) enable
################ Internal variables and commands ################
# Group: DDT internal variables
# Here is some information about the internal variables.
# The following array variables contain information about the
# instrumentalized source scripts and files. All of them are using the
# source identifier as array index.
#
# DisassembleInfo - Disassemble information of the source
# SourceScript - Source script
# SourceIScript - Instrumentalized source script
# CommandPosListN - List of character positions that correspond to a command
# begin
# CommandPosListRC - List of line/column positions that correspond to a
# command begin
#
# Registered source files and breakpoints.
#
# SourceFiles - Source file name list
# BP - Breakpoint array
#
# The following variables contain information about the execution state of
# the program being debugged.
#
# ExecSourceId - Source identifier
# ExecLineNbr - Currently executed line number
# ExecState - Execution state (see <ddt::GetExecState>)
# Group: DDT internal commands
# Internal commands used by DDT.
##########################
# Proc: ddt::Init
# Initializes, or re-initializes all variables used internally by DDT.
# The source file list and the defined breakpoints will be kept unless
# a full initialization is performed.
#
# Parameters:
# [FullInit] - A full initialization will be performed if set to 1
#
# Returns:
# -
#
# See Also:
# <DDT internal variables>
##########################
proc ddt::Init { {FullInit 0} } {
# Array variables containing information about the instrumentalized
# files. They will be deleted.
foreach var {
DisassembleInfo
SourceScript SourceIScript CommandPosListN CommandPosListRC
} {
variable $var
catch {unset $var}
}
# Variables defining the execution state of the debugged file
variable ExecSourceId 0
variable ExecLineNbr ""
variable ExecState ""
# The file indexes and defined breakpoints are only initialized when a
# full/first initialization is performed
if {$FullInit} {
variable SourceFiles {}
catch {variable BP; unset BP}
}
return
}
# Perform the initial variable initialization
ddt::Init 1
################ Source file handling ################
##########################
# Proc: ddt::GetSourceId
# Returns the source identifier for a file. The source identifier is an
# integer.
#
# Parameters:
# FileName - File name (can also be a fictitious identifier)
#
# Returns:
# Source identifier
#
# See Also:
# <ddt::GetSource>
##########################
proc ddt::GetSourceId {FileName} {
variable SourceFiles
if {[file exists $FileName]} {
set FileName [file normalize $FileName]
}
set SrcId [lsearch -exact $SourceFiles $FileName]
if {$SrcId<0} {
set SrcId [llength $SourceFiles]
lappend SourceFiles $FileName
}
return $SrcId
}
##########################
# Proc: ddt::GetSource
# Returns the source (e.g. script) designated by the file name.
#
# Parameters:
# FileName - File name (can also be a fictitious identifier)
#
# Returns:
# Source script
#
# See Also:
# <ddt::GetSourceId>
##########################
proc ddt::GetSource {FileName} {
variable SourceScript
set SrcId [GetSourceId $FileName]
return $SourceScript($SrcId)
}
##########################
# Proc: ddt::GetInstrumentalizedSource
# Get the instrumentalized source script of a file or of a script. This
# command can be used in 2 ways.
# * Just a file is provided but not a script: In this case the file
# content is read, instrumentalized and returned.
# * A file and a script is provided. The provided script is
# instrumentalized and returned in this case. The file name is used as
# identifier to cache instrumentalized source script.
#
# Parameters:
# FileName - File name (can also be a fictitious identifier)
# [Script] - If provided this script will be instrumentalized
#
# Returns:
# Instrumentalized source script
#
# See Also:
# <ddt::Run>, <ddt::Instrumentalize>, <ddt::GetSourceId>, <ddt::GetSource>
##########################
proc ddt::GetInstrumentalizedSource {FileName {Script {}}} {
variable SourceIScript
set SrcId [Instrumentalize $FileName $Script]
return $SourceIScript($SrcId)
}
################ Script source handling ################
##########################
# Proc: ddt::source_debug
# Tcl source command patch. This command instrumentalizes the sourced
# files and execute them then in debug mode if the following conditions
# are satisfied:
# * Currently executed code is part of the debugged program (not part of
# the debug environment)
# * Sourced file is not sourced from a package
# * The source command is not called with the -encoding option
# * The sourced file is not pkgIndex.tcl
# If one of these conditions is not satisfied, source_debug will source
# the file via the normal source command.
#
# Parameters:
# args - Arguments normally provided to *source*
#
# Returns:
# Return value normally provided by *source*
#
# See Also:
# <ddt::package_debug>, <ddt::info_debug>
##########################
proc ddt::source_debug {args} {
# Get information about the current debugging state and about eventual
# packages sourced on a higher stack level. Store the previous sourced
# file.
set ExecState [::ddt::GetExecState]
set PastSourceFile $::ddt::CurrentSourcedFile
set EvalResult ""
# Source the file via the initial source command if one of the debug
# conditions is not satisfied
if {$::ddt::PackageCommandIsExecuted || [llength $args]>1 ||
($ExecState!="cont" && $ExecState!="step") ||
[file tail [lindex $args end]]=="pkgIndex.tcl"} {
set ::ddt::CurrentSourcedFile ""; # With this definition the initial 'info script' will be used
set EvalCode [catch {uplevel 1 [concat ::ddt::source_orig $args]} EvalResult]
# Instrumentalize the script and execute this instrumentalized script if
# the specified debug conditions are satisfied
} else {
set ::ddt::CurrentSourcedFile [lindex $args end]
set SourceIScript [::ddt::GetInstrumentalizedSource [lindex $args end]]
set EvalCode [catch {uplevel 1 $SourceIScript} EvalResult]
}
# Restore the previous source file, and return the result from the
# original source command
set ::ddt::CurrentSourcedFile $PastSourceFile
return -code $EvalCode $EvalResult
}
##########################
# Proc: ddt::package_debug
# Tcl package command patch. This command keeps track about packages that
# are going to be loaded. This information is used by the patched source
# command (<ddt::source_debug>) to disable the instrumentalization of
# sourced files if they are sourced by the package command.
#
# Parameters:
# args - Arguments of the *package* command
#
# Returns:
# Return value of the *package* command
#
# See Also:
# <ddt::source_debug>, <ddt::info_debug>
##########################
proc ddt::package_debug {args} {
incr ::ddt::PackageCommandIsExecuted
set EvalResult ""
set EvalCode [catch {uplevel 1 [concat ::ddt::package_orig $args]} EvalResult]
incr ::ddt::PackageCommandIsExecuted -1
return -code $EvalCode $EvalResult
}
##########################
# Proc: ddt::info_debug
# Patches the info command. The 'info script' command doesn't work for
# scripts that are sourced in debug mode (e.g. executed as
# instrumentalized script). This patch corrects this behaviour.
#
# Parameters:
# args - Arguments to the *info* command
#
# Returns:
# Return value of the *info* command
#
# See Also:
# <ddt::source_debug>, <ddt::package_debug>
##########################
proc ddt::info_debug {args} {
# Return the name of the currently executed instrumentalized script
if {[lindex $args 0]=="script" && $::ddt::CurrentSourcedFile!=""} {
set EvalResult $::ddt::CurrentSourcedFile
set EvalCode 0
# Execute the initial info command otherwise
} else {
set EvalCode [catch {uplevel 1 [concat ::ddt::info_orig $args]} EvalResult]
}
return -code $EvalCode $EvalResult
}
################ Instrumentalizer ################
##########################
# Proc: ddt::BuildCommandPositionsCmdString
# Identifies the command positions in a command's last argument.
# *BuildCommandPositionsCmdString* extracts the scripts provided as
# last arguments to a commands (ex 'proc', 'foreach' and
# 'namespace eval' and evaluates the position of the commands contained
# inside the script. *BuildCommandPositionsCmdString* calls
# *BuildCommandPositions* to get the command positions, after removing
# the {} or "" that encloses the scripts.
#
# Parameters:
# CmdString - Command string that has as last argument a script
# SrcId - Source identifier of the script
# Offset - Position offset, used for the analysis of sub-scripts
#
# Returns:
# -
#
# See Also:
# <ddt::BuildCommandPositions>, <ddt::Instrumentalize>
##########################
proc ddt::BuildCommandPositionsCmdString {CmdString SrcId Offset} {
# Extract the script inside the last argument of the command string.
# Ignore the command if cannot be handled by list commands
if {[catch {set LastArg [lindex $CmdString end]}]} return
# Extract the script collection ({} or "") and whitespaces around the
# script
# CmdString: ' proc a { puts 1; puts 2 } '
# Lead/\____LastArg___/\Tail/
# Don't instrumentalize the last argument's script if it is not embedded
# into {} or "".
regexp {.\s*$} $CmdString Tail
set RelOffset [expr [string length $CmdString]-\
[string length $Tail]-[string length $LastArg]-1]
set Lead [string index $CmdString $RelOffset]
if {$Lead!="\{"} return; # Last argument is not starting with \{, don't instrumentalize this part
# Call BuildCommandPositions to evaluate the script's command position.
# Provide the absolute offset of this script
BuildCommandPositions $LastArg $SrcId [expr $Offset+$RelOffset+1]
return
}
##########################
# Proc: ddt::BuildCommandPositions
# Identifies the positions of the commands that are present in a script.
# These positions are stored inside the array variables *CommandPosListN*
# and *CommandPosListRC*.
#
# To identify the command position BuildCommandPositions uses the
# outputs from Tcl's ::tcl::unsupported::disassemble command. This output
# is stored inside the array variable *DisassembleInfo*.
#
# BuildCommandPositions is recursively called for code sections that
# are not byte compiled (e.g. proc, namespace, foreach). The optional
# argument *Offset* defines the offset position of the sub script inside
# the full script.
# Parameters:
# Script - Script for which the command positions have to be analysed
# SrcId - Source identifier of the script
# [Offset] - Position offset, used for the analysis of sub-scripts
#
# Returns:
# -
#
# See Also:
# <ddt::BuildCommandPositionsCmdString>, <ddt::Instrumentalize>
##########################
proc ddt::BuildCommandPositions {Script SrcId {Offset 0}} {
variable CommandPosListN
variable CommandPosListRC
variable DisassembleInfo
# Initialize the command position variables and disassemble info variable
# if BuildCommandPositions is called for the full script (e.g. offset=0)
if {$Offset==0} {
set CommandPosListN($SrcId) {}
set CommandPosListRC($SrcId) {}
set DisassembleInfo($SrcId) ""
}
# Replace line extensions by spaces, the character positions of the
# commands will not be changed in this way
regsub -all {\\\n} $Script { } CleanedScript;
# Disassemble the script, and add this info to the disassemble info array:
set DisAssScript [::tcl::unsupported::disassemble script $CleanedScript]
append DisassembleInfo($SrcId) "$DisAssScript\n"
append DisassembleInfo($SrcId) "[string repeat * 40]\n"
# Parse the the command position inside the 'Commands' section.
# Commands 22:
# 1: pc 0-5, src 0-8 2: pc 6-49, src 11-49
# 3: pc 17-30, src 31-36 4: pc 31-37, src 41-47
# 5: pc 50-85, src 52-73 6: pc 61-73, src 67-72
# Command 1: "set v 123"
# Return if the script doesn't contain any commands (empty procedure,
# empty script).
if {![regexp {\n\s*Commands \d+:(.*)\n\s*Command 1:} $DisAssScript {} CommandLocationMatches]} {
return
}
# Extract from the command position string (e.g. 'src 31-36') the command
# start and end positions.
foreach {str p0 p1} [regexp -inline -all {, src (\d+)-(\d+)} $CommandLocationMatches] {
lappend CommandLocations [list $p0 $p1]
}
# Loop through all positions, from the script end to the script begin.
# If the command contains as argument a sub script that is not
# disassembled, call 'BuildCommandPositionsCmdString' that will handle this
# sub script (by calling recursively again 'BuildCommandPositions').
foreach Location [lsort -decreasing -integer -index 0 $CommandLocations] {
# Extract the full command, including the arguments, inside the
# script, and extract further the command and the eventual sub command.
set ScriptSnip [string range $CleanedScript [lindex $Location 0] [lindex $Location 1]]
if {![regexp {^([^\s]+)\s*(\w*)} $ScriptSnip {} Command SubCommand]} {
continue; # This should never happen. Let's just ignore this problem.
}
# Evaluate the absolute command start and end position (that includes
# the offset).
set NewOrig [expr {$Offset+[lindex $Location 0]}]
set NewEnd [expr {$Offset+[lindex $Location 1]}]
# Check if the command uses as arguments scripts that are not handled
# (in this run) by the disassembler. Handle this code section in this
# case via 'BuildCommandPositionsCmdString'. Otherwise, add the absolute
# command positions ot the variable 'CommandPosListN'.
if {$Command=="proc"} {
BuildCommandPositionsCmdString $ScriptSnip $SrcId $NewOrig
} elseif {$Command=="namespace" && $SubCommand=="eval"} {
BuildCommandPositionsCmdString $ScriptSnip $SrcId $NewOrig
} elseif {$Command=="dict" && $SubCommand=="for"} {
BuildCommandPositionsCmdString $ScriptSnip $SrcId $NewOrig
} elseif {$Command=="foreach"} {
BuildCommandPositionsCmdString $ScriptSnip $SrcId $NewOrig
lappend CommandPosListN($SrcId) [list $NewOrig $NewEnd]
} else {
lappend CommandPosListN($SrcId) [list $NewOrig $NewEnd]
}
}
# Filter the command positions. This step will happen only on a script
# top level and will be skipped if a sub-script is processed (e.g. offset
# not 0).
# The filtering will retain only the positions of the main commands of a
# script, and remove the positions of sub commands (e.g. only the
# position for 'set' is retained, but not the position for 'expr').
# set Var [expr {$Var*2}]
if {$Offset!=0} return
# Order the command position list
set CommandPosListN($SrcId) [lsort -increasing -integer -index 0 $CommandPosListN($SrcId)]
# Evaluate the character positions of all line begins
set LineBeginPosList [regexp -line -all -indices -inline {^} $Script]
lappend LineBeginPosList [string length $Script]
# Initialize the variables used for the filtering and row/col evaluation
set LastCommandEndPos -1; # End position of the previous command
set LineNbr 0; # Counts the processed lines
set LineBeginPos 0; # Absolute position of the currently processed line
set NextLineBeginPos [lindex $LineBeginPosList 1 0]; # .. and of the next line
set CommandPosListRC2 {}; # Command position list (row/col info)
set CommandPosListN2 {}; # Command position list (absolute char position)
# Loop through the command positions, starting at the script end
foreach CommandPos $CommandPosListN($SrcId) {
set CommandEndPos [lindex $CommandPos 1]
set CommandPos [lindex $CommandPos 0]
# If the new command is in a new line, update the line start position
while {$CommandPos>=$NextLineBeginPos} {
set LineBeginPos $NextLineBeginPos
incr LineNbr
set NextLineBeginPos [lindex $LineBeginPosList $LineNbr+1 0]
}
# Skip the new command sequence if it is part of the last command (sub
# call) and if it starts not with "\{' or '\"'. The debug break
# command can not be inserted correctly into the code in this case.
# Examples:
# - if {$a>10} continue -> if {$a>10} ::ddt::Brk; continue : Wrong!
# - if {$a>10} {continue} -> if {$a>10} {::ddt::Brk; continue} : OK
if {$CommandPos<=$LastCommandEndPos} {
set LastCommandSequenceBegin [expr {$CommandPos-1}]