-
Notifications
You must be signed in to change notification settings - Fork 1
/
trowser.tcl
executable file
·9222 lines (7856 loc) · 292 KB
/
trowser.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
#!/bin/sh
# the next line restarts using wish \
exec wish "$0" -- "$@"
# ------------------------------------------------------------------------ #
# Copyright (C) 2007-2010,2019-2020,2023 T. Zoerner
# ------------------------------------------------------------------------ #
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.
# ------------------------------------------------------------------------ #
#
# DESCRIPTION: Browser for line-oriented text files, e.g. debug traces.
#
# ------------------------------------------------------------------------ #
#
# This function is used during start-up to define fonts, colors and
# global event binding tags.
#
proc InitResources {} {
global font_normal font_bold
# override default font for the Tk message box
option add *Dialog.msg.font {helvetica 9 bold} userDefault
# fonts for text and label widgets
set font_normal {helvetica 9 normal}
set font_bold {helvetica 9 bold}
# bindings to allow scrolling a text widget with the mouse wheel
bind TextWheel <Button-4> {%W yview scroll -3 units}
bind TextWheel <Button-5> {%W yview scroll 3 units}
bind TextWheel <MouseWheel> {%W yview scroll [expr {- (%D / 120) * 3}] units}
if {[info tclversion] eq "8.5"} {
# bindings for a read-only text widget
# copy allowed bindings from the regular text widget (i.e. move, mark, copy)
foreach event {<ButtonPress-1> <ButtonRelease-1> <B1-Motion> <Double-Button-1> <Shift-Button-1> \
<Triple-Button-1> <Triple-Shift-Button-1> <Button-2> <B2-Motion> \
<<Copy>> <<Clear>> <Shift-Key-Tab> <Control-Key-Tab> <Control-Shift-Key-Tab> \
<Key-Prior> <Key-Next> \
<Shift-Key-Next> <Shift-Key-Prior> <Control-Key-Down> <Control-Key-Up> \
<Control-Key-Left> <Control-Key-Right> <Control-Key-Next> <Control-Key-Prior> \
<Key-Home> <Key-End> <Shift-Key-Home> <Shift-Key-End> <Control-Key-Home> \
<Control-Key-End> <Control-Shift-Key-Home> <Control-Shift-Key-End> \
<Control-Shift-Key-Left> <Control-Shift-Key-Right> <Control-Shift-Key-Down>
<Control-Shift-Key-Up>} {
bind TextReadOnly $event [bind Text $event]
}
foreach event {<Key-Down> <Key-Up> <Key-Left> <Key-Right> <Control-Key-slash> \
<Shift-Key-Left> <Shift-Key-Right> <Shift-Key-Up> <Shift-Key-Down>} {
bind TextReadOnly $event [bind Text $event]
}
} else {
set text_modifier_events {
<<Clear>> <<Cut>> <<Paste>> <<PasteSelection>>
<<Redo>> <<Undo>> <<TkAccentBackspace>> <Key-BackSpace>
<Key> <Key-Delete> <Key-Insert> <Key-Return>
# Not modifiers, but events are overridden below
<Key-Up> <Key-Down> <Key-Left> <Key-Right>
<Control-Key-Home> <Control-Key-End> <Key-Tab> <Control-Key-c>}
foreach event [bind Text] {
if {[lsearch -exact $text_modifier_events $event] == -1} {
bind TextReadOnly $event [bind Text $event]
}
}
# since Tk 8.6 there are no event handlers for <Key-Up> in tag Text anymore
bind TextReadOnly <Key-Up> {CursorMoveUpDown .f1.t -1}
bind TextReadOnly <Key-Down> {CursorMoveUpDown .f1.t 1}
bind TextReadOnly <Key-Left> {CursorMoveLeftRight .f1.t -1}
bind TextReadOnly <Key-Right> {CursorMoveLeftRight .f1.t 1}
bind TextReadOnly <Control-Key-Home> {CursorGotoLine .f1.t start}
bind TextReadOnly <Control-Key-End> {CursorGotoLine .f1.t end}
}
# bindings for a selection text widget (listbox emulation)
# (uses non-standard cursor movement event bindings, hence not added here)
foreach event {<Button-2> <B2-Motion> <Key-Prior> <Key-Next> \
<Shift-Key-Tab> <Control-Key-Tab> <Control-Shift-Key-Tab>} {
bind TextSel $event [bind Text $event]
}
foreach event {<Button-4> <Button-5> <MouseWheel>} {
bind TextReadOnly $event [bind TextWheel $event]
bind TextSel $event [bind TextWheel $event]
}
bind TextReadOnly <Control-Key-c> [bind Text <<Copy>>]
bind TextReadOnly <Key-Tab> [bind Text <Control-Key-Tab>]
bind TextSel <Key-Tab> [bind Text <Control-Key-Tab>]
# bookmark image which is inserted into the text widget
global img_marker
set img_marker [image create photo -data R0lGODlhBwAHAMIAAAAAuPj8+Hh8+JiYmDAw+AAAAAAAAAAAACH5BAEAAAEALAAAAAAHAAcAAAMUGDGsSwSMJ0RkpEIG4F2d5DBTkAAAOw==]
}
#
# This function creates the main window of the trace browser, including the
# menu at the top, the text area and a vertical scrollbar in the middle, and
# the search control dialog at the bottom.
#
proc CreateMainWindow {} {
global font_content col_bg_content col_fg_content fmt_selection
global main_win_geom fmt_find fmt_findinc
global tlb_find tlb_hall tlb_case tlb_regexp
# menubar at the top of the main window
menu .menubar
. config -menu .menubar
.menubar add cascade -label "Control" -menu .menubar.ctrl -underline 0
.menubar add cascade -label "Search" -menu .menubar.search -underline 0
.menubar add cascade -label "Bookmarks" -menu .menubar.mark -underline 0
.menubar add cascade -label "Help" -menu .menubar.help
menu .menubar.ctrl -tearoff 0 -postcommand MenuPosted
.menubar.ctrl add command -label "Open file..." -command MenuCmd_OpenFile
.menubar.ctrl add command -label "Reload current file" -state disabled -command MenuCmd_Reload
.menubar.ctrl add separator
.menubar.ctrl add command -label "Discard above cursor..." -command {MenuCmd_Discard 0}
.menubar.ctrl add command -label "Discard below cursor..." -command {MenuCmd_Discard 1}
.menubar.ctrl add separator
.menubar.ctrl add command -label "Font selection..." -command FontList_OpenDialog
.menubar.ctrl add command -label "Toggle line-wrap" -command ToggleLineWrap -accelerator "Alt-w"
.menubar.ctrl add separator
.menubar.ctrl add command -label "Quit" -command {UserQuit; update}
menu .menubar.search -tearoff 0 -postcommand MenuPosted
.menubar.search add command -label "Search history..." -command SearchHistory_Open
.menubar.search add command -label "Edit highlight patterns..." -command TagList_OpenDialog
.menubar.search add separator
.menubar.search add command -label "List all search matches..." -command {SearchAll 1 0} -accelerator "ALT-a"
.menubar.search add command -label "List all matches above..." -command {SearchAll 1 -1} -accelerator "ALT-P"
.menubar.search add command -label "List all matches below..." -command {SearchAll 1 1} -accelerator "ALT-N"
.menubar.search add separator
.menubar.search add command -label "Clear search highlight" -command {SearchHighlightClear} -accelerator "&"
.menubar.search add separator
.menubar.search add command -label "Goto line number..." -command {KeyCmd_OpenDialog goto}
menu .menubar.mark -tearoff 0 -postcommand MenuPosted
.menubar.mark add command -label "Toggle bookmark" -accelerator "m" -command Mark_ToggleAtInsert
.menubar.mark add command -label "List bookmarks" -command MarkList_OpenDialog
.menubar.mark add command -label "Delete all bookmarks" -command Mark_DeleteAll
.menubar.mark add separator
.menubar.mark add command -label "Jump to prev. bookmark" -command {Mark_JumpNext 0} -accelerator "'-"
.menubar.mark add command -label "Jump to next bookmark" -command {Mark_JumpNext 1} -accelerator "'+"
.menubar.mark add separator
.menubar.mark add command -label "Read bookmarks from file..." -command Mark_ReadFileFrom
.menubar.mark add command -label "Save bookmarks to file..." -command Mark_SaveFileAs
menu .menubar.help -tearoff 0 -postcommand MenuPosted
.menubar.help add command -label "About" -command OpenAboutDialog
# frame #1: text widget and scrollbar
frame .f1
text .f1.t -width 1 -height 1 -wrap none -yscrollcommand {.f1.sb set} \
-font $font_content -background $col_bg_content -foreground $col_fg_content \
-cursor top_left_arrow -relief flat -exportselection 1
pack .f1.t -side left -fill both -expand 1
scrollbar .f1.sb -orient vertical -command {.f1.t yview} -takefocus 0
pack .f1.sb -side left -fill y
pack .f1 -side top -fill both -expand 1
focus .f1.t
# note: order is important: "find" must be lower than highlighting tags
eval [linsert [HighlightConfigure $fmt_find] 0 .f1.t tag configure find]
eval [linsert [HighlightConfigure $fmt_findinc] 0 .f1.t tag configure findinc]
.f1.t tag configure margin -lmargin1 17
.f1.t tag configure bookmark -lmargin1 0
eval [linsert [HighlightConfigure $fmt_selection] 0 .f1.t tag configure sel]
.f1.t tag lower sel
bindtags .f1.t {.f1.t TextReadOnly . all}
# commands to scroll the X/Y view
KeyBinding_UpDown .f1.t
KeyBinding_LeftRight .f1.t
# commands to move the cursor
bind .f1.t <Key-Home> {if {%s == 0} {CursorSetColumn .f1.t left; KeyClr; break}}
bind .f1.t <Key-End> {if {%s == 0} {CursorSetColumn .f1.t right; KeyClr; break}}
bind .f1.t <Key-space> {CursorMoveLeftRight .f1.t 1; break}
bind .f1.t <Key-BackSpace> {CursorMoveLeftRight .f1.t -1; break}
KeyCmdBind .f1.t "h" {event generate .f1.t <Left>}
KeyCmdBind .f1.t "l" {event generate .f1.t <Right>}
KeyCmdBind .f1.t "Return" {CursorMoveLine .f1.t 1}
KeyCmdBind .f1.t "w" {CursorMoveWord 1 0 0}
KeyCmdBind .f1.t "e" {CursorMoveWord 1 0 1}
KeyCmdBind .f1.t "b" {CursorMoveWord 0 0 0}
KeyCmdBind .f1.t "W" {CursorMoveWord 1 1 0}
KeyCmdBind .f1.t "E" {CursorMoveWord 1 1 1}
KeyCmdBind .f1.t "B" {CursorMoveWord 0 1 0}
KeyCmdBind .f1.t "ge" {CursorMoveWord 0 0 1}
KeyCmdBind .f1.t "gE" {CursorMoveWord 0 1 1}
KeyCmdBind .f1.t ";" {SearchCharInLine {} 1}
KeyCmdBind .f1.t "," {SearchCharInLine {} -1}
# commands for searching & repeating
KeyCmdBind .f1.t "/" {SearchEnter 1}
KeyCmdBind .f1.t "?" {SearchEnter 0}
KeyCmdBind .f1.t "n" {SearchNext 1}
KeyCmdBind .f1.t "N" {SearchNext 0}
KeyCmdBind .f1.t "*" {SearchWord 1}
KeyCmdBind .f1.t "#" {SearchWord 0}
KeyCmdBind .f1.t "&" {SearchHighlightClear}
bind .f1.t <Alt-Key-f> {focus .f2.e; KeyClr; break}
bind .f1.t <Alt-Key-n> {SearchNext 1; KeyClr; break}
bind .f1.t <Alt-Key-p> {SearchNext 0; KeyClr; break}
bind .f1.t <Alt-Key-h> {SearchHighlightOnOff; KeyClr; break}
bind .f1.t <Alt-Key-a> {SearchAll 0 0; KeyClr; break}
bind .f1.t <Alt-Key-N> {SearchAll 0 1; KeyClr; break}
bind .f1.t <Alt-Key-P> {SearchAll 0 -1; KeyClr; break}
# misc
KeyCmdBind .f1.t "i" {SearchList_Open 0; SearchList_CopyCurrentLine}
KeyCmdBind .f1.t "u" SearchList_Undo
bind .f1.t <Control-Key-r> SearchList_Redo
bind .f1.t <Control-Key-g> {DisplayLineNumber; KeyClr; break}
bind .f1.t <Control-Key-o> {CursorJumpHistory .f1.t -1; KeyClr; break}
bind .f1.t <Control-Key-i> {CursorJumpHistory .f1.t 1; KeyClr; break}
bind .f1.t <Double-Button-1> {if {%s == 0} {Mark_ToggleAtInsert; KeyClr; break}}
KeyCmdBind .f1.t "m" {Mark_ToggleAtInsert}
bind .f1.t <Alt-Key-w> {ToggleLineWrap; break}
bind .f1.t <Control-plus> {ChangeFontSize 1; KeyClr}
bind .f1.t <Control-minus> {ChangeFontSize -1; KeyClr}
bind .f1.t <Control-Alt-Delete> DebugDumpAllState
# catch-all (processes "KeyCmdBind" from above)
bind .f1.t <FocusIn> {KeyClr}
bind .f1.t <Return> {if {[KeyCmd .f1.t Return]} break}
bind .f1.t <KeyPress> {if {[KeyCmd .f1.t %A]} break}
#bind .f1.t <Triple-Button-3> ShowDebugConsole
# frame #2: search controls
frame .f2 -borderwidth 2 -relief raised
label .f2.l -text "Find:" -underline 0
entry .f2.e -width 20 -textvariable tlb_find -exportselection false
menu .f2.mh -tearoff 0
button .f2.bn -text "Next" -command {SearchNext 1} -underline 0 -pady 2
button .f2.bp -text "Prev." -command {SearchNext 0} -underline 0 -pady 2
button .f2.bl -text "All" -command {SearchAll 1 0} -underline 0 -pady 2
checkbutton .f2.bh -text "Highlight all" -variable tlb_hall -command SearchHighlightSettingChange -underline 0
checkbutton .f2.cb -text "Match case" -variable tlb_case -command SearchHighlightSettingChange -underline 6
checkbutton .f2.re -text "Reg.Exp." -variable tlb_regexp -command SearchHighlightSettingChange -underline 4
pack .f2.l .f2.e .f2.bn .f2.bp .f2.bl .f2.bh .f2.cb .f2.re -side left -anchor w -padx 1
pack configure .f2.e -fill x -expand 1
pack .f2 -side top -fill x
bind .f2.e <Escape> {SearchAbort; break}
bind .f2.e <Return> {SearchReturn; break}
bind .f2.e <FocusIn> {SearchInit}
bind .f2.e <FocusOut> {SearchLeave}
bind .f2.e <Control-n> {SearchIncrement 1 0; break}
bind .f2.e <Control-N> {SearchIncrement 0 0; break}
bind .f2.e <Key-Up> {Search_BrowseHistory 1; break}
bind .f2.e <Key-Down> {Search_BrowseHistory 0; break}
bind .f2.e <Control-d> {Search_Complete; break}
bind .f2.e <Control-D> {Search_CompleteLeft; break}
bind .f2.e <Control-x> {Search_RemoveFromHistory; break}
bind .f2.e <Control-c> {SearchAbort; break}
# disabled in v1.2 because of possible conflict with misconfigured backspace key
#bind .f2.e <Control-h> {TagList_AddSearch .; break}
#bind .f2.e <Control-H> {SearchHistory_Open; break}
bind .f2.e <Alt-Key-n> {SearchNext 1; break}
bind .f2.e <Alt-Key-p> {SearchNext 0; break}
bind .f2.e <Alt-Key-a> {SearchAll 0 0; break}
bind .f2.e <Alt-Key-N> {SearchAll 0 1; break}
bind .f2.e <Alt-Key-P> {SearchAll 0 -1; break}
bind .f2.e <Alt-Key-c> {set tlb_case [expr {!$tlb_case}]; SearchHighlightSettingChange; break}
bind .f2.e <Alt-Key-e> {set tlb_regexp [expr {!$tlb_regexp}]; SearchHighlightSettingChange; break}
trace add variable tlb_find write SearchVarTrace
wm protocol . WM_DELETE_WINDOW UserQuit
wm geometry . $main_win_geom
wm positionfrom . user
bind .f1.t <Configure> {ToplevelResized %W . .f1.t main_win_geom}
}
#
# This function creates the requested bitmaps if they don't exist yet
#
proc CreateButtonBitmap {args} {
foreach img $args {
if {[catch {image height $img}] != 0} {
switch -exact $img {
img_dropdown {
# image for drop-down menu copied from combobox.tcl by Bryan Oakley
image create bitmap img_dropdown -data \
"#define down_arrow_width 15
#define down_arrow_height 15
static char down_arrow_bits[] = {
0x00,0x80,0x00,0x80,0x00,0x80,0x00,0x80,
0x00,0x80,0xf8,0x8f,0xf0,0x87,0xe0,0x83,
0xc0,0x81,0x80,0x80,0x00,0x80,0x00,0x80,
0x00,0x80,0x00,0x80,0x00,0x80};"
}
img_down {
image create bitmap img_down -data \
"#define ptr_down_width 16
#define ptr_down_height 14
static unsigned char ptr_down_bits[] = {
0xc0,0x01,0xc0,0x01,0xc0,0x01,0xc0,0x01,
0xc0,0x01,0xc0,0x01,0xc0,0x01,0xc0,0x01,
0xc0,0x01,0xf8,0x0f,0xf0,0x07,0xe0,0x03,
0xc0,0x01,0x80,0x00};"
}
img_up {
image create bitmap img_up -data \
"#define ptr_up_width 16
#define ptr_up_height 14
static unsigned char ptr_up_bits[] = {
0x80,0x00,0xc0,0x01,0xe0,0x03,0xf0,0x07,
0xf8,0x0f,0xc0,0x01,0xc0,0x01,0xc0,0x01,
0xc0,0x01,0xc0,0x01,0xc0,0x01,0xc0,0x01,
0xc0,0x01,0xc0,0x01};"
}
}
}
}
}
# ----------------------------------------------------------------------------
#
# This function is called during start-up to create tags for all color
# highlights.
#
proc HighlightCreateTags {} {
global patlist
foreach w $patlist {
set tagnam [lindex $w 4]
set cfg [HighlightConfigure $w]
eval [linsert $cfg 0 .f1.t tag configure $tagnam]
.f1.t tag lower $tagnam find
}
}
#
# This function is called after loading a new text to apply the color
# highlighting to the complete text. This means all matches on all
# highlight patterns has to be searched for. Since this can take some
# time, the operation done in the background to avoid blocking the user.
# The CPU is given up voluntarily after each pattern and after max. 100ms
#
proc HighlightInit {} {
global patlist tid_high_init
if {[info commands .hipro] ne ""} {
destroy .hipro
}
if {[llength $patlist] > 0} {
# create a progress bar as overlay to the main window
frame .hipro -takefocus 0 -relief sunken -borderwidth 2
canvas .hipro.c -width 100 -height 10 -highlightthickness 0 -takefocus 0
pack .hipro.c
set cid [.hipro.c create rect 0 0 0 12 -fill {#0b1ff7} -outline {}]
place .hipro -in .f1.t -anchor nw -x 0 -y 0
.f1.t tag add margin 1.0 end
.f1.t configure -cursor watch
# trigger highlighting for the 1st pattern in the background
set tid_high_init [after 50 HighlightInitBg 0 $cid 0 0]
# apply highlighting on the text in the visible area (this is quick)
# use the yview callback to redo highlighting in case the user scrolls
Highlight_YviewRedirect
}
}
#
# This function is a slave-function of proc HighlightInit. The function
# loops across all members in the global pattern list to apply color
# the respective highlighting. The loop is broken up by installing each
# new iteration as an idle event (and limiting each step to 100ms)
#
proc HighlightInitBg {pat_idx cid line loop_cnt} {
global block_bg_tasks tid_search_inc tid_search_hall tid_search_list
global patlist tid_high_init
if {$block_bg_tasks || ($tid_search_inc ne {}) || ($tid_search_hall ne {}) || ($tid_search_list ne {})} {
# background tasks are suspended - re-schedule with timer
set tid_high_init [after 100 [list HighlightInitBg $pat_idx $cid $line 0]]
} elseif {$loop_cnt > 10} {
# insert a small timer delay to allow for idle-driven interactive tasks (e.g. selections)
set tid_high_init [after 10 [list HighlightInitBg $pat_idx $cid $line 0]]
} elseif {$pat_idx < [llength $patlist]} {
set w [lindex $patlist $pat_idx]
set tagnam [lindex $w 4]
set opt [Search_GetOptions [lindex $w 0] [lindex $w 1] [lindex $w 2]]
incr loop_cnt
# here we do the actual work:
# apply the tag to all matching lines of text
set line [HighlightLines [lindex $w 0] $tagnam $opt $line]
if {$line >= 0} {
# not done yet - reschedule
set tid_high_init [after idle [list HighlightInitBg $pat_idx $cid $line $loop_cnt]]
} else {
# trigger next tag
incr pat_idx
set tid_high_init [after idle [list HighlightInitBg $pat_idx $cid 1 $loop_cnt]]
# update the progress bar
catch {.hipro.c coords $cid 0 0 [expr {int(100*$pat_idx/[llength $patlist])}] 12}
}
} else {
catch {destroy .hipro}
.f1.t configure -cursor top_left_arrow
set tid_high_init {}
}
}
#
# This function searches for all lines in the main text widget which match the
# given pattern and adds the given tag to them. If the loop doesn't complete
# within 100ms, the search is paused and the function returns the number of the
# last searched line. In this case the caller must invoke the funtion again
# (as an idle event, to allow user-interaction in-between.)
#
proc HighlightLines {pat tagnam opt line} {
set pos [.f1.t index end]
scan $pos "%d.%d" max_line char
set start_t [clock clicks -milliseconds]
while {($line < $max_line) &&
([set pos [eval .f1.t search $opt -- {$pat} "$line.0" end]] ne {})} {
# match found, highlight this line
scan $pos "%d.%d" line char
.f1.t tag add $tagnam "$line.0" "[expr {$line + 1}].0"
# trigger the search result list dialog in case the line is included there too
SearchList_HighlightLine $tagnam $line
incr line
# limit the runtime of the loop - return start line number for the next invocation
if {([clock clicks -milliseconds] >= $start_t + 100) && ($line < $max_line)} {
return $line
}
}
# all done for this pattern
return -1
}
#
# This helper function schedules the line highlight function until highlighting
# is complete for the given pattern. This function is used to add highlighting
# for single tags (e.g. modified highlight patterns or colors; currently not used
# for search highlighting because a separate "cancel ID" is required.)
#
proc HighlightAll {pat tagnam opt {line 1} {loop_cnt 0}} {
global tid_high_init block_bg_tasks
if {$block_bg_tasks} {
# background tasks are suspended - re-schedule with timer
set tid_high_init [after 100 [list HighlightAll $pat $tagnam $opt $line 0]]
} elseif {$loop_cnt > 10} {
# insert a small timer delay to allow for idle-driven interactive tasks (e.g. selections)
set tid_high_init [after 10 [list HighlightAll $pat $tagnam $opt $line 0]]
} else {
set line [HighlightLines $pat $tagnam $opt $line]
if {$line >= 0} {
incr loop_cnt
set tid_high_init [after idle [list HighlightAll $pat $tagnam $opt $line $loop_cnt]]
} else {
.f1.t configure -cursor top_left_arrow
set tid_high_init {}
}
}
}
#
# This function searches the currently visible text content for all lines
# which contain the given sub-string and marks these lines with the given tag.
#
proc HighlightVisible {pat tagnam opt} {
set start_pos [.f1.t index {@1,1}]
set end_pos [.f1.t index "@[expr {[winfo width .f1.t] - 1}],[expr {[winfo height .f1.t] - 1}]"]
scan $start_pos "%d.%d" line char
scan $end_pos "%d.%d" max_line char
#puts "visible $start_pos...$end_pos: $pat $opt"
while {($line < $max_line) &&
([set pos [eval .f1.t search $opt -- {$pat} "$line.0" end]] ne {})} {
scan $pos "%d.%d" line char
.f1.t tag add $tagnam "$line.0" "[expr {$line + 1}].0"
incr line
}
}
#
# This callback is installed to the main text widget's yview. It is used
# to detect changes in the view to update highlighting if the highlighting
# task is not complete yet. The event is forwarded to the vertical scrollbar.
#
proc Highlight_YviewCallback {frac1 frac2} {
global tid_high_init tid_search_hall
if {$tid_high_init ne ""} {
global patlist
foreach w $patlist {
set opt [Search_GetOptions [lindex $w 0] [lindex $w 1] [lindex $w 2]]
HighlightVisible [lindex $w 0] [lindex $w 4] $opt
}
}
if {$tid_search_hall ne ""} {
global tlb_cur_hall_opt
HighlightVisible [lindex $tlb_cur_hall_opt 0] find [lindex $tlb_cur_hall_opt 1]
}
# automatically remove the redirect if no longer needed
if {($tid_high_init eq "") && ($tid_search_hall eq "")} {
.f1.t configure -yscrollcommand {.f1.sb set}
}
.f1.sb set $frac1 $frac2
}
#
# This function redirects the yview callback from the scrollbar into the
# above function, or undoes the redirection. This is used to install a
# redirection for the duration of the initial or search highlighting task.
#
proc Highlight_YviewRedirect {} {
.f1.t configure -yscrollcommand Highlight_YviewCallback
}
#
# This function creates or updates a text widget tag with the options of
# a color highlight entry. The function is called during start-up for all
# highlight patterns, and by the highlight edit dialog (also used for the
# sample text widget.)
#
proc HighlightConfigure {w} {
global font_content
set cfg {}
if {[lindex $w 8]} {
lappend cfg -font [DeriveFont $font_content 0 bold]
} else {
lappend cfg -font {}
}
if {[lindex $w 9]} {
lappend cfg -underline [lindex $w 9]
} else {
lappend cfg -underline {}
}
if {[lindex $w 10]} {
lappend cfg -overstrike [lindex $w 10]
} else {
lappend cfg -overstrike {}
}
if {[lindex $w 13] ne {}} {
lappend cfg -relief [lindex $w 13]
lappend cfg -borderwidth [lindex $w 14]
} else {
lappend cfg -relief {} -borderwidth {}
}
if {[lindex $w 15] > 0} {
lappend cfg -spacing1 [lindex $w 15] -spacing3 [lindex $w 15]
} else {
lappend cfg -spacing1 {} -spacing3 {}
}
lappend cfg -background [lindex $w 6]
lappend cfg -foreground [lindex $w 7]
lappend cfg -bgstipple [lindex $w 11]
lappend cfg -fgstipple [lindex $w 12]
return $cfg
}
#
# This function clears the current search color highlighting without
# resetting the search string. It's bound to the "&" key, but also used
# during regular search reset.
#
proc SearchHighlightClear {} {
global tlb_cur_hall_opt tid_search_hall
after cancel $tid_search_hall
set tid_search_hall {}
.f1.t configure -cursor top_left_arrow
.f1.t tag remove find 1.0 end
.f1.t tag remove findinc 1.0 end
set tlb_cur_hall_opt {{} {}}
SearchList_HighlightClear
}
#
# This function triggers color highlighting of all lines of text which match
# the current search string. The function is called when global highlighting
# is en-/disabled, when the search string is modified or when search options
# are changed.
#
proc SearchHighlightUpdate {pat opt} {
global tlb_hall tlb_cur_hall_opt tid_search_hall
if {$pat ne ""} {
if {$tlb_hall} {
set opt [lsearch -all -inline -regexp -not $opt {^-(forwards|backwards)$}]
if {[focus -displayof .] ne ".f2.e"} {
if {([lindex $tlb_cur_hall_opt 0] ne $pat) ||
([lindex $tlb_cur_hall_opt 1] ne $opt)} {
# display "busy" cursor until highlighting is finished
.f1.t configure -cursor watch
# kill background highlight process for obsolete pattern
after cancel $tid_search_hall
# start highlighting in the background
set tlb_cur_hall_opt [list $pat $opt]
set tid_search_hall [after 100 [list SearchHighlightAll $pat find $opt]]
# apply highlighting on the text in the visible area (this is quick)
# (note this is required in addition to the redirect below)
HighlightVisible $pat find $opt
# use the yview callback to redo highlighting in case the user scrolls
Highlight_YviewRedirect
}
} else {
HighlightVisible $pat find $opt
}
} else {
SearchHighlightClear
}
}
}
#
# This is a wrapper for the above function which works on the current
# pattern in the search entry field.
#
proc SearchHighlightUpdateCurrent {} {
global tlb_hall tlb_find tlb_regexp tlb_case
if {$tlb_hall} {
if {$tlb_find ne ""} {
if {[SearchExprCheck $tlb_find $tlb_regexp 1]} {
set opt [Search_GetOptions $tlb_find $tlb_regexp $tlb_case]
SearchHighlightUpdate $tlb_find $opt
}
}
}
}
#
# This helper function calls the global search highlight function until
# highlighting is complete.
#
proc SearchHighlightAll {pat tagnam opt {line 1} {loop_cnt 0}} {
global tid_search_hall block_bg_tasks
if {$block_bg_tasks} {
# background tasks are suspended - re-schedule with timer
set tid_search_hall [after 100 [list SearchHighlightAll $pat $tagnam $opt $line 0]]
} elseif {$loop_cnt > 10} {
# insert a small timer delay to allow for idle-driven interactive tasks (e.g. selections)
set tid_search_hall [after 10 [list SearchHighlightAll $pat $tagnam $opt $line 0]]
} else {
set line [HighlightLines $pat $tagnam $opt $line]
if {$line >= 0} {
incr loop_cnt
set tid_search_hall [after idle [list SearchHighlightAll $pat $tagnam $opt $line $loop_cnt]]
} else {
set tid_search_hall {}
.f1.t configure -cursor top_left_arrow
}
}
}
#
# This function is bound to the "Highlight all" checkbutton to en- or disable
# global highlighting.
#
proc SearchHighlightOnOff {} {
global tlb_hall
set tlb_hall [expr {!$tlb_hall}]
UpdateRcAfterIdle
SearchHighlightUpdateCurrent
}
#
# This function is invoked after a change in search settings (i.e. case
# match, reg.exp. or global highlighting.) The changed settings are
# stored in the RC file and a possible search highlighting is removed
# or updated (the latter only if global highlighting is enabled)
#
proc SearchHighlightSettingChange {} {
global tlb_hall
UpdateRcAfterIdle
SearchHighlightClear
if {$tlb_hall} {
SearchHighlightUpdateCurrent
}
}
#
# This function is invoked when the user enters text in the "find" entry field.
# In contrary to the "atomic" search, this function only searches a small chunk
# of text, then re-schedules itself as an "idle" task. The search can be aborted
# at any time by canceling the task.
#
proc Search_Background {pat is_fwd opt start is_changed callback} {
global block_bg_tasks tid_search_inc tid_search_list
global tid_search_inc
if {$block_bg_tasks} {
# background tasks are suspended - re-schedule with timer
set tid_search_inc [after 100 [list Search_Background $pat $is_fwd $opt $start $is_changed $callback]]
return
}
if {$is_fwd} {
set end [.f1.t index end]
} else {
set end "1.0"
}
if {$start ne $end} {
if {$is_fwd} {
set next [.f1.t index [concat $start + 5000 lines lineend]]
} else {
set next [.f1.t index [concat $start - 5000 lines linestart]]
}
# invoke the actual search in the text widget content
set pos [eval .f1.t search $opt -count match_len -- {$pat} $start $next]
if {$pos eq ""} {
set tid_search_inc [after idle [list Search_Background $pat $is_fwd $opt $next $is_changed $callback]]
} else {
set tid_search_inc {}
Search_HandleMatch $pos $match_len $pat $opt $is_changed
eval [list $callback $pos $pat $is_fwd $is_changed]
}
} else {
set tid_search_inc {}
Search_HandleMatch "" 0 $pat $opt $is_changed
eval [list $callback "" $pat $is_fwd $is_changed]
}
}
#
# This function searches the main text content for the expression in the
# search entry field, starting at the current cursor position. When a match
# is found, the cursor is moved there and the line is highlighed.
#
proc Search_Atomic {pat is_re use_case is_fwd is_changed} {
global tlb_hall tlb_last_dir
set pos ""
if {($pat ne "") && [SearchExprCheck $pat $is_re 1]} {
set tlb_last_dir $is_fwd
set search_opt [Search_GetOptions $pat $is_re $use_case $tlb_last_dir]
set start_pos [Search_GetBase $is_fwd 0]
CursorJumpPushPos .f1.t
if {$is_fwd} {
set search_range [list $start_pos [.f1.t index end]]
} else {
set search_range [list $start_pos "1.0"]
}
set match_len 0
if {$start_pos ne [lindex $search_range 1]} {
# invoke the actual search in the text widget content
while 1 {
set pos [eval .f1.t search $search_opt -count match_len -- {$pat} $search_range]
# work-around for backwards search:
# make sure the matching text is entirely to the left side of the cursor
if {($pos ne "") && [SearchOverlapCheck $is_fwd $start_pos $pos $match_len]} {
# match overlaps: search further backwards
set search_range [lreplace $search_range 0 0 $pos]
continue
}
break
}
} else {
set pos ""
}
# update cursor position and highlight
Search_HandleMatch $pos $match_len $pat $search_opt $is_changed
} else {
# empty or invalid expression: just remove old highlights
SearchReset
}
return $pos
}
#
# This helper function checks if the match returned for a backwards search
# overlaps the search start position (e.g. the match is 1 char left of the
# start pos, but 2 chars long)
#
proc SearchOverlapCheck {is_fwd start_pos pos match_len} {
if {$is_fwd == 0} {
# convert start position into numerical (e.g. may be "insert")
if {([scan $start_pos "%d.%d" line1 char1] == 2) ||
([scan [.f1.t index $start_pos] "%d.%d" line1 char1] == 2)} {
if {[scan $pos "%d.%d" line2 char2] == 2} {
if {($line1 == $line2) && ($char2 + $match_len > $char1)} {
return 1
}
}
}
}
return 0
}
#
# This function handles the result of a text search in the main window. If
# a match was found, the cursor is moved to the start of the match and the
# matching section and complete line are highlighted. Optionally, a background
# process to highlight all matches is started. If no match is found, any
# previously applied search highlighting is removed.
#
proc Search_HandleMatch {pos match_len pat opt is_changed} {
global tlb_find_line tlb_hall tlb_cur_hall_opt
if {($pos ne "") || $is_changed} {
if {!$tlb_hall || ([lindex $tlb_cur_hall_opt 0] ne $pat)} {
SearchHighlightClear
} else {
.f1.t tag remove findinc 1.0 end
}
}
if {$pos ne ""} {
scan $pos "%d" tlb_find_line
.f1.t see $pos
.f1.t mark set insert $pos
.f1.t tag add find "$tlb_find_line.0" "[expr {$tlb_find_line + 1}].0"
if {$match_len > 0} {
.f1.t tag add findinc $pos "$pos + $match_len chars"
}
SearchList_HighlightLine find $tlb_find_line
SearchList_MatchView $tlb_find_line
}
if {$tlb_hall} {
SearchHighlightUpdate $pat $opt
}
}
#
# This function displays a message if no match was found for a search
# pattern. This is split off from the search function so that some
# callers can override the message.
#
proc Search_HandleNoMatch {pat is_fwd} {
if {$pat ne ""} {
set pat ": $pat"
}
if {$is_fwd} {
DisplayStatusLine search warn "No match until end of file$pat"
} else {
DisplayStatusLine search warn "No match until start of file$pat"
}
}
#
# This function is bound to all changes of the search text in the
# "find" entry field. It's called when the user enters new text and
# triggers an incremental search.
#
proc SearchVarTrace {name1 name2 op} {
global tid_search_inc
global tlb_last_dir
after cancel $tid_search_inc
set tid_search_inc [after 50 SearchIncrement $tlb_last_dir 1]
}
#
# This function performs a so-called "incremental" search after the user
# has modified the search text. This means searches are started already
# while the user is typing.
#
proc SearchIncrement {is_fwd is_changed} {
global tlb_find tlb_regexp tlb_case tlb_last_dir tlb_inc_base tlb_inc_view
global tid_search_inc
set tid_search_inc {}
if {[focus -displayof .] eq ".f2.e"} {
if {($tlb_find ne {}) && [SearchExprCheck $tlb_find $tlb_regexp 0]} {
if {![info exists tlb_inc_base]} {
set tlb_inc_base [Search_GetBase $is_fwd 1]
set tlb_inc_view [list [lindex [.f1.t xview] 0] [lindex [.f1.t yview] 0]]
CursorJumpPushPos .f1.t
}
if {$is_changed} {
.f1.t tag remove findinc 1.0 end
.f1.t tag remove find 1.0 end
set start_pos $tlb_inc_base
#.f1.t xview moveto [lindex $tlb_inc_view 0]
#.f1.t yview moveto [lindex $tlb_inc_view 1]
#.f1.t mark set insert $tlb_inc_base
#.f1.t see insert
} else {
set start_pos [Search_GetBase $is_fwd 0]
}
set opt [Search_GetOptions $tlb_find $tlb_regexp $tlb_case $is_fwd]
Search_Background $tlb_find $is_fwd $opt $start_pos $is_changed Search_IncMatch
} else {
SearchReset
if {$tlb_find ne {}} {
DisplayStatusLine search error "Incomplete or invalid reg.exp."
} else {
ClearStatusLine search
}
}
}
}
#
# This function is invoked as callback after a background search for the
# incremental search in the entry field is completed. (Before this call,
# cursor position and search highlights are already updated.)
#
proc Search_IncMatch {pos pat is_fwd is_changed} {
global tlb_inc_base tlb_inc_view tlb_history tlb_hist_pos tlb_hist_prefix
if {($pos eq "") && [info exists tlb_inc_base]} {
if {$is_changed} {
.f1.t xview moveto [lindex $tlb_inc_view 0]
.f1.t yview moveto [lindex $tlb_inc_view 1]
.f1.t mark set insert $tlb_inc_base
.f1.t see insert
}
if {$is_fwd} {
DisplayStatusLine search warn "No match until end of file"
} else {
DisplayStatusLine search warn "No match until start of file"
}
} else {
ClearStatusLine search
}
if {[info exists tlb_hist_pos]} {
set hl [lindex $tlb_history $tlb_hist_pos]
if {$pat ne [lindex $hl 0]} {
unset tlb_hist_pos tlb_hist_prefix
}
}
}
#
# This function checks if the search pattern syntax is valid
#
proc SearchExprCheck {pat is_re display} {
global tlb_find tlb_regexp
if {$is_re && [catch {regexp -- $pat ""} cerr]} {