source: trunk/base/src/macports1.0/reclaim.tcl @ 146699

Last change on this file since 146699 was 146699, checked in by cal@…, 4 years ago

base: reclaim: Fix signals being swallowed

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 15.1 KB
Line 
1# -*- coding: utf-8; mode: tcl; tab-width: 4; indent-tabs-mode: nil; c-basic-offset: 4 -*- vim:fenc=utf-8:filetype=tcl:et:sw=4:ts=4:sts=4
2# reclaim.tcl
3# $Id: reclaim.tcl 146699 2016-03-15 15:43:50Z cal@macports.org $
4#
5# Copyright (c) 2002 - 2003 Apple Inc.
6# Copyright (c) 2004 - 2005 Paul Guyot, <pguyot@kallisys.net>.
7# Copyright (c) 2004 - 2006 Ole Guldberg Jensen <olegb@opendarwin.org>.
8# Copyright (c) 2004 - 2005 Robert Shaw <rshaw@opendarwin.org>
9# Copyright (c) 2004 - 2014 The MacPorts Project
10# All rights reserved.
11#
12# Redistribution and use in source and binary forms, with or without
13# modification, are permitted provided that the following conditions
14# are met:
15# 1. Redistributions of source code must retain the above copyright
16#    notice, this list of conditions and the following disclaimer.
17# 2. Redistributions in binary form must reproduce the above copyright
18#    notice, this list of conditions and the following disclaimer in the
19#    documentation and/or other materials provided with the distribution.
20# 3. Neither the name of Apple Inc. nor the names of its contributors
21#    may be used to endorse or promote products derived from this software
22#    without specific prior written permission.
23#
24# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
25# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
26# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
27# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
28# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
29# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
30# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
31# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
32# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
33# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
34# POSSIBILITY OF SUCH DAMAGE.
35
36# TODO:
37
38# Finished:
39# Add ui_debug statments
40# Catch some error-prone areas.
41# Remove the useless/structure comments and add actual docstrings.
42# Add copyright notice
43# Check if inactive ports are dependents of other ports.
44# Add test cases
45# Add distfile version checking.
46# Pretty sure we should be using ui_msg, instead of puts and what not. Should probably add that.
47# Register the "port cleanup" command with port.tcl and all that involves.
48# Implement a hash-map, or multidimensional array for ease of port info keeping. Write it yourself if you have to.
49# Figure out what the hell is going on with "port clean all" vs "port clean installed" the 'clean' target is provided by this package
50
51# XXX: all prompts for the user need to use the ui_ask_* API
52#      (definitely required for GUI support)
53
54package provide reclaim 1.0
55
56package require registry_uninstall 2.0
57package require macports
58
59namespace eval reclaim {
60
61    proc main {args} {
62        # The main function. Calls each individual function that needs to be run.
63        # Args:
64        #           None
65        # Returns:
66        #           None
67
68        uninstall_inactive
69        remove_distfiles
70        update_last_run
71    }
72
73    proc walk_files {dir files_in_use unused_name} {
74        # Recursively walk the given directory $dir and build a list of all files that are present on-disk but not listed in $files_in_use.
75        # The list of unused files will be stored in the variable given by $unused_name
76        #
77        # Args:
78        #           dir             - A string path of the given directory to walk through
79        #           files_in_use    - A sorted list of the full paths for all distfiles from installed ports
80        #           unused_name     - The name of a list in the caller to which unused files will be appended
81
82        upvar $unused_name unused
83
84        foreach item [readdir $dir] {
85            set currentPath [file join $dir $item]
86            switch -exact -- [file type $currentPath] {
87                directory {
88                    walk_files $currentPath $files_in_use unused
89                }
90                file {
91                    if {[lsearch -exact -sorted $files_in_use $currentPath] == -1} {
92                        ui_info "Found unused distfile $currentPath"
93                        lappend unused $currentPath
94                    }
95                }
96            }
97        }
98    }
99
100    proc remove_distfiles {} {
101        # Check for distfiles in both the root, and home directories. If found, delete them.
102        # Args:
103        #               None
104        # Returns:
105        #               0 on successful execution
106
107        global macports::portdbpath
108        global macports::user_home
109
110        # The root and home distfile folder locations, respectively.
111        set root_dist       [file join ${macports::portdbpath} distfiles]
112        set home_dist       ${macports::user_home}/.macports$root_dist
113
114        set port_info    [get_info]
115        set files_in_use [list]
116
117        set fancyOutput [expr {   ![macports::ui_isset ports_debug] \
118                               && ![macports::ui_isset ports_verbose] \
119                               && [info exists macports::ui_options(progress_generic)]}]
120        if {$fancyOutput} {
121            set progress $macports::ui_options(progress_generic)
122        } else {
123            # provide a no-op if there is no progress function
124            proc noop {args} {}
125            set progress noop
126        }
127
128        ui_msg "$macports::ui_prefix Building list of files still in use"
129        set port_count [llength $port_info]
130        set i 1
131        $progress start
132
133        foreach port $port_info {
134            set name     [lindex $port 0]
135            set version  [lindex $port 1]
136            set revision [lindex $port 2]
137            set variants [lindex $port 3]
138
139            # Get mport reference
140            try -pass_signal {
141                set mport [mportopen_installed $name $version $revision $variants {}]
142            } catch {{*} eCode eMessage} {
143                $progress intermission
144                ui_warn [msgcat::mc "Failed to open port %s from registry: %s" $name $eMessage]
145                continue
146            }
147
148            # Setup sub-Tcl-interpreter that executed the installed port
149            set workername [ditem_key $mport workername]
150
151            # Append that port's distfiles to the list
152            set dist_subdir [$workername eval return {$dist_subdir}]
153            set distfiles   [$workername eval return {$distfiles}]
154            set patchfiles  [$workername eval [list if {[exists patchfiles]} { return $patchfiles } else { return [list] }]]
155
156            foreach distfile [concat $distfiles $patchfiles] {
157                set root_path [file join $root_dist $dist_subdir $distfile]
158                set home_path [file join $home_dist $dist_subdir $distfile]
159
160                # Add the full file path to the list, depending where it's located.
161                if {[file isfile $root_path]} {
162                    ui_info "Keeping $root_path"
163                    lappend files_in_use $root_path
164                }
165                if {[file isfile $home_path]} {
166                    ui_info "Keeping $home_path"
167                    lappend files_in_use $home_path
168                }
169            }
170
171            $progress update $i $port_count
172            incr i
173        }
174
175        $progress finish
176
177        ui_msg "$macports::ui_prefix Searching for unused files"
178
179        # sort so we can use binary search in walk_files
180        set files_in_use [lsort -unique $files_in_use]
181
182        ui_debug "Calling walk_files on root directory."
183
184        set superfluous_files [list]
185        walk_files $root_dist $files_in_use superfluous_files
186
187        if {[file exists $home_dist]} {
188            ui_debug "Calling walk_files on home directory."
189            walk_files $home_dist $files_in_use superfluous_files
190        }
191
192        set num_superfluous_files [llength $superfluous_files]
193        set size_superfluous_files 0
194        foreach f $superfluous_files {
195            incr size_superfluous_files [file size $f]
196        }
197        if {[llength $superfluous_files] > 0} {
198            ui_msg [msgcat::mc \
199                "Found %d files (total %s) that are no longer needed and can be deleted." \
200                $num_superfluous_files \
201                [bytesize $size_superfluous_files]]
202            while {1} {
203                ui_msg "\[D]elete / \[k]eep / \[l]ist: "
204                switch [gets stdin] {
205                    d -
206                    D {
207                        ui_msg "Deleting..."
208                        foreach f $superfluous_files {
209                            set root_length [string length "${root_dist}/"]
210                            set home_length [string length "${home_dist}/"]
211
212                            try -pass_signal {
213                                ui_info [msgcat::mc "Deleting unused file %s" $f]
214                                file delete -- $f
215
216                                set directory [file dirname $f]
217                                while {1} {
218                                    set is_below_root [string equal -length $root_length $directory "${root_dist}/"]
219                                    set is_below_home [string equal -length $home_length $directory "${home_dist}/"]
220
221                                    if {!$is_below_root && !$is_below_home} {
222                                        break
223                                    }
224
225                                    if {[llength [readdir $directory]] > 0} {
226                                        break
227                                    }
228
229                                    ui_info [msgcat::mc "Deleting empty directory %s" $directory]
230                                    try -pass_signal {
231                                        file delete -- $directory
232                                    } catch {{*} eCode eMessage} {
233                                        ui_warn [msgcat::mc "Could not delete empty directory %s: %s" $directory $eMesage]
234                                    }
235                                    set directory [file dirname $directory]
236                                }
237                            } catch {{*} eCode eMessage} {
238                                ui_warn [msgcat::mc "Could not delete %s: %s" $f $eMessage]
239                            }
240                        }
241                        break
242                    }
243                    k -
244                    K {
245                        ui_msg "OK, keeping the files."
246                        break
247                    }
248                    l -
249                    L {
250                        foreach f $superfluous_files {
251                            ui_msg "  $f"
252                        }
253                    }
254                }
255            }
256        } else {
257            ui_msg "No unused files found."
258        }
259
260        return 0
261    }
262
263    proc is_inactive {port} {
264
265        # Determines whether a port is inactive or not.
266        # Args:
267        #           port - An array where the fourth item in it is the activity of the port.
268        # Returns:
269        #           1 if inactive, 0 if active.
270
271        if {[lindex $port 4] == 0} {
272            ui_debug "Port [lindex $port 0] is inactive."
273            return 1
274        }
275        ui_debug "Port [lindex $port 0] is not inactive."
276        return 0
277    }
278
279    proc get_info {} {
280
281        # Gets the information of all installed ports (those returned by registry::installed), and returns it in a
282        # multidimensional list.
283        #
284        # Args:
285        #           None
286        # Returns:
287        #           A multidimensional list where each port is a sublist, i.e., [{first port info} {second port info} {...}]
288        #           Indexes of each sublist are: 0 = name, 1 = version, 2 = revision, 3 = variants, 4 = activity, and 5 = epoch.
289       
290        try -pass_signal {
291            return [registry::installed]
292        } catch {*} {
293            ui_error "no installed ports found."
294            return {}
295        }
296    }
297
298    proc update_last_run {} {
299       
300        # Updates the last_reclaim textfile with the newest time the code has been ran.
301        #
302        # Args:
303        #           None
304        # Returns:
305        #           None
306
307        ui_debug "Updating last run information."
308
309        set path [file join ${macports::portdbpath} last_reclaim]
310        set fd -1
311        try -pass_signal {
312            set fd [open $path w]
313            puts $fd [clock seconds]
314        } finally {
315            if {$fd != -1} {
316                close $fd
317            }
318        }
319    }
320
321    proc check_last_run {} {
322
323        # Periodically warns the user that they haven't run 'port reclaim' in two weeks, and that they should consider doing so.
324        #
325        # Args:
326        #           None
327        # Returns:
328        #           None
329
330        ui_debug "Checking time since last reclaim run"
331
332        set path [file join ${macports::portdbpath} last_reclaim]
333
334        set fd -1
335        set time ""
336        try -pass_signal {
337            set fd [open $path r]
338            set time [gets $fd]
339        } finally {
340            if {$fd != -1} {
341                close $fd
342            }
343        }
344        if {$time ne ""} {
345            if {[clock seconds] - $time > 1209600} {
346                ui_warn "You haven't run 'port reclaim' in two weeks. It's recommended you run this every two weeks to reclaim disk space."
347            }
348        }
349    }
350
351    proc uninstall_inactive {} {
352
353        # Attempts to uninstall all inactive ports. (Performance is now O(N)!)
354        #
355        # Args:
356        #           None
357        # Returns:
358        #           0 if execution was successful. Errors (for now) if execution wasn't.
359
360        set ports           [get_info]
361        set inactive_ports  [list]
362        set inactive_names  [list]
363        set inactive_count  0
364
365        ui_debug "Iterating through all inactive ports."
366
367        foreach port $ports {
368
369            if { [is_inactive $port] } {
370                lappend inactive_ports $port
371                lappend inactive_names [lindex $port 0]
372                incr inactive_count
373            }
374        }
375
376        if { $inactive_count == 0 } {
377            ui_msg "Found no inactive ports."
378
379        } else {
380
381            ui_msg "Found inactive ports: $inactive_names."
382            if {[info exists macports::ui_options(questions_multichoice)]} {
383                set retstring [$macports::ui_options(questions_multichoice) "Would you like to uninstall these ports?" "" $inactive_names]
384
385                if {[llength $retstring] > 0} {
386                    foreach i $retstring {
387                        set port [lindex $inactive_ports $i]
388                        set name [lindex $port 0]
389
390                        ui_msg "Uninstalling: $name"
391
392                        # Note: 'uninstall' takes a name, version, revision, variants and an options list.
393                        try -pass_signal {
394                            registry_uninstall::uninstall $name [lindex $port 1] [lindex $port 2] [lindex $port 3] {}
395                        } catch {{*} eCode eMessage} {
396                            ui_error "Error uninstalling $name: $eMessage"
397                        }
398                    }
399                } else {
400                    ui_msg "Not uninstalling ports."
401                }
402            }
403        }
404        return 0
405    }
406}
Note: See TracBrowser for help on using the repository browser.