git-gui: revert untracked files by deleting them
Update the revert_helper proc to check for untracked files as well as changes, and then handle changes to be reverted and untracked files with independent blocks of code. Prompt the user independently for untracked files, since the underlying action is fundamentally different (rm -f). If after deleting untracked files, the directory containing them becomes empty, then remove the directory as well. Migrate unlocking of the index out of _close_updateindex to a responsibility of the caller, to permit paths that don't directly unlock the index, and refactor the error handling added in d4e890e5 so that callers can make flow control decisions in the event of errors. Update Tcl/Tk dependency from 8.4 to 8.6 in git-gui.sh. A new proc delete_files takes care of actually deleting the files in batches, using the Tcler's Wiki recommended approach for keeping the UI responsive. Since the checkout_index and delete_files calls are both asynchronous and could potentially complete in any order, a "chord" is used to coordinate unlocking the index and returning the UI to a usable state only after both operations are complete. The `SimpleChord` class, based on TclOO (Tcl/Tk 8.6), is added in this commit. Signed-off-by: Jonathan Gilbert <JonathanG@iQmetrix.com> Signed-off-by: Pratyush Yadav <me@yadavpratyush.com>
Jonathan Gilbert committed
Dec 1, 2019 at 02:28 UTC
fa38ab68b0ac409f695efcaa23b8bcda84defd41
3 files changed
+502
-84
git-gui.sh
+2
-2
@@ -30,8 +30,8 @@ along with this program; if not, see <http://www.gnu.org/licenses/>.}]
30
##
31
## Tcl/Tk sanity check
32
33
-if {[catch {package require Tcl 8.4} err]
34
- || [catch {package require Tk 8.4} err]
33
+if {[catch {package require Tcl 8.6} err]
34
+ || [catch {package require Tk 8.6} err]
35
} {
36
catch {wm withdraw .}
37
tk_messageBox \
lib/chord.tcl
new
+160
@@ -0,0 +1,160 @@
1
+# Simple Chord for Tcl
2
+#
3
+# A "chord" is a method with more than one entrypoint and only one body, such
4
+# that the body runs only once all the entrypoints have been called by
5
+# different asynchronous tasks. In this implementation, the chord is defined
6
+# dynamically for each invocation. A SimpleChord object is created, supplying
7
+# body script to be run when the chord is completed, and then one or more notes
8
+# are added to the chord. Each note can be called like a proc, and returns
9
+# immediately if the chord isn't yet complete. When the last remaining note is
10
+# called, the body runs before the note returns.
11
+#
12
+# The SimpleChord class has a constructor that takes the body script, and a
13
+# method add_note that returns a note object. Since the body script does not
14
+# run in the context of the procedure that defined it, a mechanism is provided
15
+# for injecting variables into the chord for use by the body script. The
16
+# activation of a note is idempotent; multiple calls have the same effect as
17
+# a simple call.
18
+#
19
+# If you are invoking asynchronous operations with chord notes as completion
20
+# callbacks, and there is a possibility that earlier operations could complete
21
+# before later ones are started, it is a good practice to create a "common"
22
+# note on the chord that prevents it from being complete until you're certain
23
+# you've added all the notes you need.
24
+#
25
+# Example:
26
+#
27
+# # Turn off the UI while running a couple of async operations.
28
+# lock_ui
29
+#
30
+# set chord [SimpleChord new {
31
+# unlock_ui
32
+# # Note: $notice here is not referenced in the calling scope
33
+# if {$notice} { info_popup $notice }
34
+# }
35
+#
36
+# # Configure a note to keep the chord from completing until
37
+# # all operations have been initiated.
38
+# set common_note [$chord add_note]
39
+#
40
+# # Pass notes as 'after' callbacks to other operations
41
+# async_operation $args [$chord add_note]
42
+# other_async_operation $args [$chord add_note]
43
+#
44
+# # Communicate with the chord body
45
+# if {$condition} {
46
+# # This sets $notice in the same context that the chord body runs in.
47
+# $chord eval { set notice "Something interesting" }
48
+# }
49
+#
50
+# # Activate the common note, making the chord eligible to complete
51
+# $common_note
52
+#
53
+# At this point, the chord will complete at some unknown point in the future.
54
+# The common note might have been the first note activated, or the async
55
+# operations might have completed synchronously and the common note is the
56
+# last one, completing the chord before this code finishes, or anything in
57
+# between. The purpose of the chord is to not have to worry about the order.
58
+
59
+# SimpleChord class:
60
+# Represents a procedure that conceptually has multiple entrypoints that must
61
+# all be called before the procedure executes. Each entrypoint is called a
62
+# "note". The chord is only "completed" when all the notes are "activated".
63
+oo::class create SimpleChord {
64
+ variable notes body is_completed
65
+
66
+ # Constructor:
67
+ # set chord [SimpleChord new {body}]
68
+ # Creates a new chord object with the specified body script. The
69
+ # body script is evaluated at most once, when a note is activated
70
+ # and the chord has no other non-activated notes.
71
+ constructor {body} {
72
+ set notes [list]
73
+ my eval [list set body $body]
74
+ set is_completed 0
75
+ }
76
+
77
+ # Method:
78
+ # $chord eval {script}
79
+ # Runs the specified script in the same context (namespace) in which
80
+ # the chord body will be evaluated. This can be used to set variable
81
+ # values for the chord body to use.
82
+ method eval {script} {
83
+ namespace eval [self] $script
84
+ }
85
+
86
+ # Method:
87
+ # set note [$chord add_note]
88
+ # Adds a new note to the chord, an instance of ChordNote. Raises an
89
+ # error if the chord is already completed, otherwise the chord is
90
+ # updated so that the new note must also be activated before the
91
+ # body is evaluated.
92
+ method add_note {} {
93
+ if {$is_completed} { error "Cannot add a note to a completed chord" }
94
+
95
+ set note [ChordNote new [self]]
96
+
97
+ lappend notes $note
98
+
99
+ return $note
100
+ }
101
+
102
+ # This method is for internal use only and is intentionally undocumented.
103
+ method notify_note_activation {} {
104
+ if {!$is_completed} {
105
+ foreach note $notes {
106
+ if {![$note is_activated]} { return }
107
+ }
108
+
109
+ set is_completed 1
110
+
111
+ namespace eval [self] $body
112
+ namespace delete [self]
113
+ }
114
+ }
115
+}
116
+
117
+# ChordNote class:
118
+# Represents a note within a chord, providing a way to activate it. When the
119
+# final note of the chord is activated (this can be any note in the chord,
120
+# with all other notes already previously activated in any order), the chord's
121
+# body is evaluated.
122
+oo::class create ChordNote {
123
+ variable chord is_activated
124
+
125
+ # Constructor:
126
+ # Instances of ChordNote are created internally by calling add_note on
127
+ # SimpleChord objects.
128
+ constructor {chord} {
129
+ my eval set chord $chord
130
+ set is_activated 0
131
+ }
132
+
133
+ # Method:
134
+ # [$note is_activated]
135
+ # Returns true if this note has already been activated.
136
+ method is_activated {} {
137
+ return $is_activated
138
+ }
139
+
140
+ # Method:
141
+ # $note
142
+ # Activates the note, if it has not already been activated, and
143
+ # completes the chord if there are no other notes awaiting
144
+ # activation. Subsequent calls will have no further effect.
145
+ #
146
+ # NB: In TclOO, if an object is invoked like a method without supplying
147
+ # any method name, then this internal method `unknown` is what
148
+ # actually runs (with no parameters). It is used in the ChordNote
149
+ # class for the purpose of allowing the note object to be called as
150
+ # a function (see example above). (The `unknown` method can also be
151
+ # used to support dynamic dispatch, but must take parameters to
152
+ # identify the "unknown" method to be invoked. In this form, this
153
+ # proc serves only to make instances behave directly like methods.)
154
+ method unknown {} {
155
+ if {!$is_activated} {
156
+ set is_activated 1
157
+ $chord notify_note_activation
158
+ }
159
+ }
160
+}
lib/index.tcl
+340
-82
@@ -7,53 +7,60 @@ proc _delete_indexlock {} {
7
}
8
}
9
10
-proc _close_updateindex {fd after} {
11
- global use_ttk NS
12
- fconfigure $fd -blocking 1
13
- if {[catch {close $fd} err]} {
14
- set w .indexfried
15
- Dialog $w
16
- wm withdraw $w
17
- wm title $w [strcat "[appname] ([reponame]): " [mc "Index Error"]]
18
- wm geometry $w "+[winfo rootx .]+[winfo rooty .]"
19
- set s [mc "Updating the Git index failed. A rescan will be automatically started to resynchronize git-gui."]
20
- text $w.msg -yscrollcommand [list $w.vs set] \
21
- -width [string length $s] -relief flat \
22
- -borderwidth 0 -highlightthickness 0 \
23
- -background [get_bg_color $w]
24
- $w.msg tag configure bold -font font_uibold -justify center
25
- ${NS}::scrollbar $w.vs -command [list $w.msg yview]
26
- $w.msg insert end $s bold \n\n$err {}
27
- $w.msg configure -state disabled
28
-
29
- ${NS}::button $w.continue \
30
- -text [mc "Continue"] \
31
- -command [list destroy $w]
32
- ${NS}::button $w.unlock \
33
- -text [mc "Unlock Index"] \
34
- -command "destroy $w; _delete_indexlock"
35
- grid $w.msg - $w.vs -sticky news
36
- grid $w.unlock $w.continue - -sticky se -padx 2 -pady 2
37
- grid columnconfigure $w 0 -weight 1
38
- grid rowconfigure $w 0 -weight 1
39
-
40
- wm protocol $w WM_DELETE_WINDOW update
41
- bind $w.continue <Visibility> "
42
- grab $w
43
- focus %W
44
- "
45
- wm deiconify $w
46
- tkwait window $w
47
-
48
- $::main_status stop_all
10
+proc close_and_unlock_index {fd after} {
11
+ if {![catch {_close_updateindex $fd} err]} {
12
unlock_index
50
- rescan $after 0
51
- return
13
+ uplevel #0 $after
14
+ } else {
15
+ rescan_on_error $err $after
16
}
17
+}
18
+
19
+proc _close_updateindex {fd} {
20
+ fconfigure $fd -blocking 1
21
+ close $fd
22
+}
23
+
24
+proc rescan_on_error {err {after {}}} {
25
+ global use_ttk NS
26
+
27
+ set w .indexfried
28
+ Dialog $w
29
+ wm withdraw $w
30
+ wm title $w [strcat "[appname] ([reponame]): " [mc "Index Error"]]
31
+ wm geometry $w "+[winfo rootx .]+[winfo rooty .]"
32
+ set s [mc "Updating the Git index failed. A rescan will be automatically started to resynchronize git-gui."]
33
+ text $w.msg -yscrollcommand [list $w.vs set] \
34
+ -width [string length $s] -relief flat \
35
+ -borderwidth 0 -highlightthickness 0 \
36
+ -background [get_bg_color $w]
37
+ $w.msg tag configure bold -font font_uibold -justify center
38
+ ${NS}::scrollbar $w.vs -command [list $w.msg yview]
39
+ $w.msg insert end $s bold \n\n$err {}
40
+ $w.msg configure -state disabled
41
+
42
+ ${NS}::button $w.continue \
43
+ -text [mc "Continue"] \
44
+ -command [list destroy $w]
45
+ ${NS}::button $w.unlock \
46
+ -text [mc "Unlock Index"] \
47
+ -command "destroy $w; _delete_indexlock"
48
+ grid $w.msg - $w.vs -sticky news
49
+ grid $w.unlock $w.continue - -sticky se -padx 2 -pady 2
50
+ grid columnconfigure $w 0 -weight 1
51
+ grid rowconfigure $w 0 -weight 1
52
+
53
+ wm protocol $w WM_DELETE_WINDOW update
54
+ bind $w.continue <Visibility> "
55
+ grab $w
56
+ focus %W
57
+ "
58
+ wm deiconify $w
59
+ tkwait window $w
60
61
$::main_status stop_all
62
unlock_index
56
- uplevel #0 $after
63
+ rescan [concat $after [list ui_ready]] 0
64
}
65
66
proc update_indexinfo {msg path_list after} {
@@ -93,7 +100,7 @@ proc write_update_indexinfo {fd path_list total_cnt batch status_bar_operation \
100
101
if {$update_index_cp >= $total_cnt} {
102
$status_bar_operation stop
96
- _close_updateindex $fd $after
103
+ close_and_unlock_index $fd $after
104
return
105
}
106
@@ -162,7 +169,7 @@ proc write_update_index {fd path_list total_cnt batch status_bar_operation \
169
170
if {$update_index_cp >= $total_cnt} {
171
$status_bar_operation stop
165
- _close_updateindex $fd $after
172
+ close_and_unlock_index $fd $after
173
return
174
}
175
@@ -199,7 +206,7 @@ proc write_update_index {fd path_list total_cnt batch status_bar_operation \
206
$status_bar_operation update $update_index_cp $total_cnt
207
}
208
202
-proc checkout_index {msg path_list after} {
209
+proc checkout_index {msg path_list after capture_error} {
210
global update_index_cp
211
212
if {![lock_index update]} return
@@ -232,17 +239,33 @@ proc checkout_index {msg path_list after} {
239
$batch \
240
$status_bar_operation \
241
$after \
242
+ $capture_error \
243
]
244
}
245
246
proc write_checkout_index {fd path_list total_cnt batch status_bar_operation \
239
- after} {
247
+ after capture_error} {
248
global update_index_cp
249
global file_states current_diff_path
250
251
if {$update_index_cp >= $total_cnt} {
252
$status_bar_operation stop
245
- _close_updateindex $fd $after
253
+
254
+ # We do not unlock the index directly here because this
255
+ # operation expects to potentially run in parallel with file
256
+ # deletions scheduled by revert_helper. We're done with the
257
+ # update index, so we close it, but actually unlocking the index
258
+ # and dealing with potential errors is deferred to the chord
259
+ # body that runs when all async operations are completed.
260
+ #
261
+ # (See after_chord in revert_helper.)
262
+
263
+ if {[catch {_close_updateindex $fd} err]} {
264
+ uplevel #0 $capture_error [list $err]
265
+ }
266
+
267
+ uplevel #0 $after
268
+
269
return
270
}
271
@@ -397,66 +420,301 @@ proc do_add_all {} {
420
add_helper [mc "Adding all changed files"] $paths
421
}
422
423
+# Copied from TclLib package "lambda".
424
+proc lambda {arguments body args} {
425
+ return [list ::apply [list $arguments $body] {*}$args]
426
+}
427
+
428
proc revert_helper {txt paths} {
429
global file_states current_diff_path
430
431
if {![lock_index begin-update]} return
432
433
+ # Common "after" functionality that waits until multiple asynchronous
434
+ # operations are complete (by waiting for them to activate their notes
435
+ # on the chord).
436
+ #
437
+ # The asynchronous operations are each indicated below by a comment
438
+ # before the code block that starts the async operation.
439
+ set after_chord [SimpleChord new {
440
+ if {[string trim $err] != ""} {
441
+ rescan_on_error $err
442
+ } else {
443
+ unlock_index
444
+ if {$should_reshow_diff} { reshow_diff }
445
+ ui_ready
446
+ }
447
+ }]
448
+
449
+ $after_chord eval { set should_reshow_diff 0 }
450
+
451
+ # This function captures an error for processing when after_chord is
452
+ # completed. (The chord is curried into the lambda function.)
453
+ set capture_error [lambda \
454
+ {chord error} \
455
+ { $chord eval [list set err $error] } \
456
+ $after_chord]
457
+
458
+ # We don't know how many notes we're going to create (it's dynamic based
459
+ # on conditional paths below), so create a common note that will delay
460
+ # the chord's completion until we activate it, and then activate it
461
+ # after all the other notes have been created.
462
+ set after_common_note [$after_chord add_note]
463
+
464
set path_list [list]
406
- set after {}
465
+ set untracked_list [list]
466
+
467
foreach path $paths {
468
switch -glob -- [lindex $file_states($path) 0] {
469
U? {continue}
470
+ ?O {
471
+ lappend untracked_list $path
472
+ }
473
?M -
474
?T -
475
?D {
476
lappend path_list $path
477
if {$path eq $current_diff_path} {
415
- set after {reshow_diff;}
478
+ $after_chord eval { set should_reshow_diff 1 }
479
}
480
}
481
}
482
}
483
484
+ set path_cnt [llength $path_list]
485
+ set untracked_cnt [llength $untracked_list]
486
+
487
+ # Asynchronous operation: revert changes by checking them out afresh
488
+ # from the index.
489
+ if {$path_cnt > 0} {
490
+ # Split question between singular and plural cases, because
491
+ # such distinction is needed in some languages. Previously, the
492
+ # code used "Revert changes in" for both, but that can't work
493
+ # in languages where 'in' must be combined with word from
494
+ # rest of string (in different way for both cases of course).
495
+ #
496
+ # FIXME: Unfortunately, even that isn't enough in some languages
497
+ # as they have quite complex plural-form rules. Unfortunately,
498
+ # msgcat doesn't seem to support that kind of string
499
+ # translation.
500
+ #
501
+ if {$path_cnt == 1} {
502
+ set query [mc \
503
+ "Revert changes in file %s?" \
504
+ [short_path [lindex $path_list]] \
505
+ ]
506
+ } else {
507
+ set query [mc \
508
+ "Revert changes in these %i files?" \
509
+ $path_cnt]
510
+ }
511
422
- # Split question between singular and plural cases, because
423
- # such distinction is needed in some languages. Previously, the
424
- # code used "Revert changes in" for both, but that can't work
425
- # in languages where 'in' must be combined with word from
426
- # rest of string (in different way for both cases of course).
427
- #
428
- # FIXME: Unfortunately, even that isn't enough in some languages
429
- # as they have quite complex plural-form rules. Unfortunately,
430
- # msgcat doesn't seem to support that kind of string translation.
431
- #
432
- set n [llength $path_list]
433
- if {$n == 0} {
434
- unlock_index
435
- return
436
- } elseif {$n == 1} {
437
- set query [mc "Revert changes in file %s?" [short_path [lindex $path_list]]]
438
- } else {
439
- set query [mc "Revert changes in these %i files?" $n]
512
+ set reply [tk_dialog \
513
+ .confirm_revert \
514
+ "[appname] ([reponame])" \
515
+ "$query
516
+
517
+[mc "Any unstaged changes will be permanently lost by the revert."]" \
518
+ question \
519
+ 1 \
520
+ [mc "Do Nothing"] \
521
+ [mc "Revert Changes"] \
522
+ ]
523
+
524
+ if {$reply == 1} {
525
+ checkout_index \
526
+ $txt \
527
+ $path_list \
528
+ [$after_chord add_note] \
529
+ $capture_error
530
+ }
531
}
532
442
- set reply [tk_dialog \
443
- .confirm_revert \
444
- "[appname] ([reponame])" \
445
- "$query
533
+ # Asynchronous operation: Deletion of untracked files.
534
+ if {$untracked_cnt > 0} {
535
+ # Split question between singular and plural cases, because
536
+ # such distinction is needed in some languages.
537
+ #
538
+ # FIXME: Unfortunately, even that isn't enough in some languages
539
+ # as they have quite complex plural-form rules. Unfortunately,
540
+ # msgcat doesn't seem to support that kind of string
541
+ # translation.
542
+ #
543
+ if {$untracked_cnt == 1} {
544
+ set query [mc \
545
+ "Delete untracked file %s?" \
546
+ [short_path [lindex $untracked_list]] \
547
+ ]
548
+ } else {
549
+ set query [mc \
550
+ "Delete these %i untracked files?" \
551
+ $untracked_cnt \
552
+ ]
553
+ }
554
447
-[mc "Any unstaged changes will be permanently lost by the revert."]" \
448
- question \
449
- 1 \
450
- [mc "Do Nothing"] \
451
- [mc "Revert Changes"] \
452
- ]
453
- if {$reply == 1} {
454
- checkout_index \
455
- $txt \
555
+ set reply [tk_dialog \
556
+ .confirm_revert \
557
+ "[appname] ([reponame])" \
558
+ "$query
559
+
560
+[mc "Files will be permanently deleted."]" \
561
+ question \
562
+ 1 \
563
+ [mc "Do Nothing"] \
564
+ [mc "Delete Files"] \
565
+ ]
566
+
567
+ if {$reply == 1} {
568
+ $after_chord eval { set should_reshow_diff 1 }
569
+
570
+ delete_files $untracked_list [$after_chord add_note]
571
+ }
572
+ }
573
+
574
+ # Activate the common note. If no other notes were created, this
575
+ # completes the chord. If other notes were created, then this common
576
+ # note prevents a race condition where the chord might complete early.
577
+ $after_common_note
578
+}
579
+
580
+# Delete all of the specified files, performing deletion in batches to allow the
581
+# UI to remain responsive and updated.
582
+proc delete_files {path_list after} {
583
+ # Enable progress bar status updates
584
+ set status_bar_operation [$::main_status \
585
+ start \
586
+ [mc "Deleting"] \
587
+ [mc "files"]]
588
+
589
+ set path_index 0
590
+ set deletion_errors [list]
591
+ set batch_size 50
592
+
593
+ delete_helper \
594
+ $path_list \
595
+ $path_index \
596
+ $deletion_errors \
597
+ $batch_size \
598
+ $status_bar_operation \
599
+ $after
600
+}
601
+
602
+# Helper function to delete a list of files in batches. Each call deletes one
603
+# batch of files, and then schedules a call for the next batch after any UI
604
+# messages have been processed.
605
+proc delete_helper {path_list path_index deletion_errors batch_size \
606
+ status_bar_operation after} {
607
+ global file_states
608
+
609
+ set path_cnt [llength $path_list]
610
+
611
+ set batch_remaining $batch_size
612
+
613
+ while {$batch_remaining > 0} {
614
+ if {$path_index >= $path_cnt} { break }
615
+
616
+ set path [lindex $path_list $path_index]
617
+
618
+ set deletion_failed [catch {file delete -- $path} deletion_error]
619
+
620
+ if {$deletion_failed} {
621
+ lappend deletion_errors [list "$deletion_error"]
622
+ } else {
623
+ remove_empty_directories [file dirname $path]
624
+
625
+ # Don't assume the deletion worked. Remove the file from
626
+ # the UI, but only if it no longer exists.
627
+ if {![path_exists $path]} {
628
+ unset file_states($path)
629
+ display_file $path __
630
+ }
631
+ }
632
+
633
+ incr path_index 1
634
+ incr batch_remaining -1
635
+ }
636
+
637
+ # Update the progress bar to indicate that this batch has been
638
+ # completed. The update will be visible when this procedure returns
639
+ # and allows the UI thread to process messages.
640
+ $status_bar_operation update $path_index $path_cnt
641
+
642
+ if {$path_index < $path_cnt} {
643
+ # The Tcler's Wiki lists this as the best practice for keeping
644
+ # a UI active and processing messages during a long-running
645
+ # operation.
646
+
647
+ after idle [list after 0 [list \
648
+ delete_helper \
649
$path_list \
457
- [concat $after [list ui_ready]]
650
+ $path_index \
651
+ $deletion_errors \
652
+ $batch_size \
653
+ $status_bar_operation \
654
+ $after
655
+ ]]
656
} else {
459
- unlock_index
657
+ # Finish the status bar operation.
658
+ $status_bar_operation stop
659
+
660
+ # Report error, if any, based on how many deletions failed.
661
+ set deletion_error_cnt [llength $deletion_errors]
662
+
663
+ if {($deletion_error_cnt > 0)
664
+ && ($deletion_error_cnt <= [MAX_VERBOSE_FILES_IN_DELETION_ERROR])} {
665
+ set error_text [mc "Encountered errors deleting files:\n"]
666
+
667
+ foreach deletion_error $deletion_errors {
668
+ append error_text "* [lindex $deletion_error 0]\n"
669
+ }
670
+
671
+ error_popup $error_text
672
+ } elseif {$deletion_error_cnt == $path_cnt} {
673
+ error_popup [mc \
674
+ "None of the %d selected files could be deleted." \
675
+ $path_cnt \
676
+ ]
677
+ } elseif {$deletion_error_cnt > 1} {
678
+ error_popup [mc \
679
+ "%d of the %d selected files could not be deleted." \
680
+ $deletion_error_cnt \
681
+ $path_cnt \
682
+ ]
683
+ }
684
+
685
+ uplevel #0 $after
686
+ }
687
+}
688
+
689
+proc MAX_VERBOSE_FILES_IN_DELETION_ERROR {} { return 10; }
690
+
691
+# This function is from the TCL documentation:
692
+#
693
+# https://wiki.tcl-lang.org/page/file+exists
694
+#
695
+# [file exists] returns false if the path does exist but is a symlink to a path
696
+# that doesn't exist. This proc returns true if the path exists, regardless of
697
+# whether it is a symlink and whether it is broken.
698
+proc path_exists {name} {
699
+ expr {![catch {file lstat $name finfo}]}
700
+}
701
+
702
+# Remove as many empty directories as we can starting at the specified path,
703
+# walking up the directory tree. If we encounter a directory that is not
704
+# empty, or if a directory deletion fails, then we stop the operation and
705
+# return to the caller. Even if this procedure fails to delete any
706
+# directories at all, it does not report failure.
707
+proc remove_empty_directories {directory_path} {
708
+ set parent_path [file dirname $directory_path]
709
+
710
+ while {$parent_path != $directory_path} {
711
+ set contents [glob -nocomplain -dir $directory_path *]
712
+
713
+ if {[llength $contents] > 0} { break }
714
+ if {[catch {file delete -- $directory_path}]} { break }
715
+
716
+ set directory_path $parent_path
717
+ set parent_path [file dirname $directory_path]
718
}
719
}
720