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

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

Use the ui_ask_alternative API.

Use the ui_ask_alternative API implemented in r146738.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 15.8 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 146741 2016-03-16 17:26:29Z ijackson@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            if {[info exists macports::ui_options(questions_alternative)]} {
199                array set alternatives {d delete k keep l list}
200                set retstring [$macports::ui_options(questions_alternative) [msgcat::mc \
201                    "Found %d files (total %s) that are no longer needed and can be deleted." \
202                    $num_superfluous_files [bytesize $size_superfluous_files]] "deleteFilesQ" "alternatives" {k}]
203               
204                while 1 {
205                    switch $retstring {
206                        d {
207                            ui_msg "Deleting..."
208                            foreach f $superfluous_files {
209                                set home_length [string length "${home_dist}/"]
210
211                                try -pass_signal {
212                                    ui_info [msgcat::mc "Deleting unused file %s" $f]
213                                    file delete -- $f
214
215                                    set directory [file dirname $f]
216                                    while {1} {
217                                        set is_below_root [string equal -length $root_length $directory "${root_dist}/"]
218                                        set is_below_home [string equal -length $home_length $directory "${home_dist}/"]
219
220                                        if {!$is_below_root && !$is_below_home} {
221                                            break
222                                        }
223
224                                        if {[llength [readdir $directory]] > 0} {
225                                            break
226                                        }
227
228                                        ui_info [msgcat::mc "Deleting empty directory %s" $directory]
229                                        try -pass_signal {
230                                            file delete -- $directory
231                                        } catch {{*} eCode eMessage} {
232                                            ui_warn [msgcat::mc "Could not delete empty directory %s: %s" $directory $eMesage]
233                                        }
234                                        set directory [file dirname $directory]
235                                    }
236                                } catch {{*} eCode eMessage} {
237                                    ui_warn [msgcat::mc "Could not delete %s: %s" $f $eMessage]
238                                }
239                            }
240                            break
241                        }
242                        k {
243                            ui_msg "OK, keeping the files."
244                            break
245                        }
246                        l {
247                            foreach f $superfluous_files {
248                                ui_msg "  $f"
249                            }
250                        }
251                    }
252                }
253            }
254        } else {
255            ui_msg "No unused files found."
256        }
257
258        return 0
259    }
260
261    proc is_inactive {port} {
262
263        # Determines whether a port is inactive or not.
264        # Args:
265        #           port - An array where the fourth item in it is the activity of the port.
266        # Returns:
267        #           1 if inactive, 0 if active.
268
269        if {[lindex $port 4] == 0} {
270            ui_debug "Port [lindex $port 0] is inactive."
271            return 1
272        }
273        ui_debug "Port [lindex $port 0] is not inactive."
274        return 0
275    }
276
277    proc get_info {} {
278
279        # Gets the information of all installed ports (those returned by registry::installed), and returns it in a
280        # multidimensional list.
281        #
282        # Args:
283        #           None
284        # Returns:
285        #           A multidimensional list where each port is a sublist, i.e., [{first port info} {second port info} {...}]
286        #           Indexes of each sublist are: 0 = name, 1 = version, 2 = revision, 3 = variants, 4 = activity, and 5 = epoch.
287       
288        try -pass_signal {
289            return [registry::installed]
290        } catch {*} {
291            ui_error "no installed ports found."
292            return {}
293        }
294    }
295
296    proc update_last_run {} {
297       
298        # Updates the last_reclaim textfile with the newest time the code has been ran.
299        #
300        # Args:
301        #           None
302        # Returns:
303        #           None
304
305        ui_debug "Updating last run information."
306
307        set path [file join ${macports::portdbpath} last_reclaim]
308        set fd -1
309        try -pass_signal {
310            set fd [open $path w]
311            puts $fd [clock seconds]
312        } catch {*} {
313            # Ignore error silently
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        } catch {*} {
340            # Ignore error silently; the file might not have been created yet
341        } finally {
342            if {$fd != -1} {
343                close $fd
344            }
345        }
346        if {$time ne ""} {
347            if {[clock seconds] - $time > 1209600} {
348                if {[info exists macports::ui_options(questions_yesno)]} {
349                    set retval [$macports::ui_options(questions_yesno)  "You haven't run 'port reclaim' in two weeks. It's recommended you run this every two weeks to reclaim disk space." "ReclaimPrompt" "" {y} 0 "Would you like to run it now?"]
350                    if {$retval == 0} {
351                        # User said yes, run port reclaim
352                        macports::reclaim_main
353                    }
354                }
355            }
356        }
357    }
358
359    proc uninstall_inactive {} {
360
361        # Attempts to uninstall all inactive ports. (Performance is now O(N)!)
362        #
363        # Args:
364        #           None
365        # Returns:
366        #           0 if execution was successful. Errors (for now) if execution wasn't.
367
368        set ports           [get_info]
369        set inactive_ports  [list]
370        set inactive_names  [list]
371        set inactive_count  0
372
373        ui_debug "Iterating through all inactive ports."
374
375        foreach port $ports {
376
377            if { [is_inactive $port] } {
378                lappend inactive_ports $port
379                lappend inactive_names [lindex $port 0]
380                incr inactive_count
381            }
382        }
383
384        if { $inactive_count == 0 } {
385            ui_msg "Found no inactive ports."
386
387        } else {
388
389            ui_msg "Found inactive ports: $inactive_names."
390            if {[info exists macports::ui_options(questions_multichoice)]} {
391                set retstring [$macports::ui_options(questions_multichoice) "Would you like to uninstall these ports?" "" $inactive_names]
392
393                if {[llength $retstring] > 0} {
394                    foreach i $retstring {
395                        set port [lindex $inactive_ports $i]
396                        set name [lindex $port 0]
397
398                        ui_msg "Uninstalling: $name"
399
400                        # Note: 'uninstall' takes a name, version, revision, variants and an options list.
401                        try -pass_signal {
402                            registry_uninstall::uninstall $name [lindex $port 1] [lindex $port 2] [lindex $port 3] {}
403                        } catch {{*} eCode eMessage} {
404                            ui_error "Error uninstalling $name: $eMessage"
405                        }
406                    }
407                } else {
408                    ui_msg "Not uninstalling ports."
409                }
410            }
411        }
412        return 0
413    }
414}
Note: See TracBrowser for help on using the repository browser.