source: trunk/base/src/port1.0/portclean.tcl

Last change on this file was 146637, checked in by cal@…, 5 years ago

port1.0: Adapt to try -pass_signal from r146633

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 11.8 KB
Line 
1# -*- coding: utf-8; mode: tcl; tab-width: 4; indent-tabs-mode: nil; c-basic-offset: 4 -*- vim:fenc=utf-8:ft=tcl:et:sw=4:ts=4:sts=4
2# $Id: portclean.tcl 146637 2016-03-14 16:55:15Z cal@macports.org $
3#
4# Copyright (c) 2005-2007, 2009-2011, 2013 The MacPorts Project
5# Copyright (c) 2004 Robert Shaw <rshaw@opendarwin.org>
6# Copyright (c) 2002 - 2003 Apple Inc.
7# All rights reserved.
8#
9# Redistribution and use in source and binary forms, with or without
10# modification, are permitted provided that the following conditions
11# are met:
12# 1. Redistributions of source code must retain the above copyright
13#    notice, this list of conditions and the following disclaimer.
14# 2. Redistributions in binary form must reproduce the above copyright
15#    notice, this list of conditions and the following disclaimer in the
16#    documentation and/or other materials provided with the distribution.
17# 3. Neither the name of Apple Inc. nor the names of its contributors
18#    may be used to endorse or promote products derived from this software
19#    without specific prior written permission.
20#
21# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
22# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
23# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
24# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
25# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
26# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
27# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
28# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
29# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
30# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
31# POSSIBILITY OF SUCH DAMAGE.
32#
33
34# the 'clean' target is provided by this package
35
36package provide portclean 1.0
37package require portutil 1.0
38package require Pextlib 1.0
39
40set org.macports.clean [target_new org.macports.clean portclean::clean_main]
41target_runtype ${org.macports.clean} always
42target_state ${org.macports.clean} no
43target_provides ${org.macports.clean} clean
44target_requires ${org.macports.clean} main
45target_prerun ${org.macports.clean} portclean::clean_start
46
47namespace eval portclean {
48}
49
50set_ui_prefix
51
52proc portclean::clean_start {args} {
53    global UI_PREFIX prefix
54
55    ui_notice "$UI_PREFIX [format [msgcat::mc "Cleaning %s"] [option subport]]"
56
57    if {[getuid] == 0 && [geteuid] != 0} {
58        elevateToRoot "clean"
59    }
60}
61
62proc portclean::clean_main {args} {
63    global UI_PREFIX ports_clean_dist ports_clean_work ports_clean_logs \
64           ports_clean_archive ports_clean_all keeplogs usealtworkpath
65
66    if {$usealtworkpath} {
67        ui_warn "Only cleaning in ~/.macports; insufficient privileges for standard locations"
68    }
69
70    if {[info exists ports_clean_all] && $ports_clean_all eq "yes" || \
71        [info exists ports_clean_dist] && $ports_clean_dist eq "yes"} {
72        ui_info "$UI_PREFIX [format [msgcat::mc "Removing distfiles for %s"] [option subport]]"
73        clean_dist
74    }
75    if {([info exists ports_clean_all] && $ports_clean_all eq "yes" || \
76        [info exists ports_clean_archive] && $ports_clean_archive eq "yes")
77        && !$usealtworkpath} {
78        ui_info "$UI_PREFIX [format [msgcat::mc "Removing temporary archives for %s"] [option subport]]"
79        clean_archive
80    }
81    if {[info exists ports_clean_all] && $ports_clean_all eq "yes" || \
82        [info exists ports_clean_work] && $ports_clean_work eq "yes" || \
83        [info exists ports_clean_archive] && $ports_clean_archive eq "yes" || \
84        [info exists ports_clean_dist] && $ports_clean_dist eq "yes" || \
85        !([info exists ports_clean_logs] && $ports_clean_logs eq "yes")} {
86         ui_info "$UI_PREFIX [format [msgcat::mc "Removing work directory for %s"] [option subport]]"
87         clean_work
88    }
89    if {(([info exists ports_clean_logs] && $ports_clean_logs eq "yes") || ($keeplogs eq "no"))
90        && !$usealtworkpath} {
91        clean_logs
92    }
93
94    return 0
95}
96
97#
98# Remove the directory where the distfiles reside.
99# This is crude, but works.
100#
101proc portclean::clean_dist {args} {
102    global name ports_force distpath dist_subdir distfiles patchfiles usealtworkpath portdbpath altprefix
103
104    # remove known distfiles for sure (if they exist)
105    set count 0
106    foreach file $distfiles {
107        set distfile [getdistname $file]
108        ui_debug "Looking for $distfile"
109        set distfile [file join $distpath $distfile]
110        if {[file isfile $distfile]} {
111            ui_debug "Removing file: $distfile"
112            if {[catch {delete $distfile} result]} {
113                ui_debug "$::errorInfo"
114                ui_error "$result"
115            }
116            incr count
117        }
118        if {!$usealtworkpath && [file isfile ${altprefix}${distfile}]} {
119            ui_debug "Removing file: ${altprefix}${distfile}"
120            if {[catch {delete ${altprefix}${distfile}} result]} {
121                ui_debug "$::errorInfo"
122                ui_error "$result"
123            }
124            incr count
125        }
126    }
127    if {$count > 0} {
128        ui_debug "$count distfile(s) removed."
129    } else {
130        ui_debug "No distfiles found to remove at $distpath"
131    }
132
133    set count 0
134    if {![info exists patchfiles]} {
135        set patchfiles ""
136    }
137    foreach file $patchfiles {
138        set patchfile [getdistname $file]
139        ui_debug "Looking for $patchfile"
140        set patchfile [file join $distpath $patchfile]
141        if {[file isfile $patchfile]} {
142            ui_debug "Removing file: $patchfile"
143            if {[catch {delete $patchfile} result]} {
144                ui_debug "$::errorInfo"
145                ui_error "$result"
146            }
147            incr count
148        }
149        if {!$usealtworkpath && [file isfile ${altprefix}${patchfile}]} {
150            ui_debug "Removing file: ${altprefix}${patchfile}"
151            if {[catch {delete ${altprefix}${patchfile}} result]} {
152                ui_debug "$::errorInfo"
153                ui_error "$result"
154            }
155            incr count
156        }
157    }
158    if {$count > 0} {
159        ui_debug "$count patchfile(s) removed."
160    } else {
161        ui_debug "No patchfiles found to remove at $distpath"
162    }
163
164    # next remove dist_subdir if only needed for this port,
165    # or if user forces us to
166    set dirlist [list]
167    if {$dist_subdir != $name} {
168        if {!([info exists ports_force] && $ports_force eq "yes")
169            && [file isdirectory $distpath]
170            && [llength [readdir $distpath]] > 0} {
171            ui_warn [format [msgcat::mc "Distfiles directory '%s' may contain distfiles needed for other ports, use the -f flag to force removal" ] $distpath]
172        } else {
173            lappend dirlist $dist_subdir
174            lappend dirlist $name
175        }
176    } else {
177        lappend dirlist $name
178    }
179    # loop through directories
180    set count 0
181    foreach dir $dirlist {
182        if {$usealtworkpath} {
183            set distdir [file join ${altprefix}${portdbpath} distfiles $dir]
184        } else {
185            set distdir [file join ${portdbpath} distfiles $dir]
186        }
187        if {[file isdirectory $distdir]} {
188            ui_debug "Removing directory: ${distdir}"
189            if {[catch {delete $distdir} result]} {
190                ui_debug "$::errorInfo"
191                ui_error "$result"
192            }
193            incr count
194        }
195        if {!$usealtworkpath && [file isdirectory ${altprefix}${distdir}]} {
196            ui_debug "Removing directory: ${altprefix}${distdir}"
197            if {[catch {delete ${altprefix}${distdir}} result]} {
198                ui_debug "$::errorInfo"
199                ui_error "$result"
200            }
201            incr count
202        }
203    }
204    if {$count > 0} {
205        ui_debug "$count distfile directory(s) removed."
206    } else {
207        ui_debug "No distfile directory found to remove."
208    }
209    return 0
210}
211
212proc portclean::clean_work {args} {
213    global portbuildpath subbuildpath worksymlink usealtworkpath altprefix portpath
214
215    if {[file isdirectory $subbuildpath]} {
216        ui_debug "Removing directory: ${subbuildpath}"
217        try -pass_signal {
218            delete $subbuildpath
219        } catch {{*} eCode eMessage} {
220            ui_debug "$::errorInfo"
221            ui_error "$eMessage"
222        }
223        # silently fail if non-empty (other subports might be using portbuildpath)
224        catch {file delete $portbuildpath}
225    } else {
226        ui_debug "No work directory found to remove at ${subbuildpath}"
227    }
228
229    if {!$usealtworkpath && [file isdirectory ${altprefix}${subbuildpath}]} {
230        ui_debug "Removing directory: ${altprefix}${subbuildpath}"
231        try -pass_signal {
232            delete ${altprefix}${subbuildpath}
233        } catch {{*} eCode eMessage} {
234            ui_debug "$::errorInfo"
235            ui_error "$eMessage"
236        }
237        catch {file delete ${altprefix}${portbuildpath}}
238    } else {
239        ui_debug "No work directory found to remove at ${altprefix}${subbuildpath}"
240    }
241
242    # Clean symlink, if necessary
243    if {![catch {file type $worksymlink} result] && $result eq "link"} {
244        ui_debug "Removing symlink: $worksymlink"
245        delete $worksymlink
246    }
247   
248    # clean port dir in alt prefix
249    if {[file exists "${altprefix}${portpath}"]} {
250        ui_debug "removing ${altprefix}${portpath}"
251        delete "${altprefix}${portpath}"
252    }
253
254    return 0
255}
256proc portclean::clean_logs {args} {
257    global portpath portbuildpath worksymlink portverbose keeplogs prefix subport
258    set logpath [getportlogpath $portpath]
259    set subdir [file join $logpath $subport]
260        if {[file isdirectory $subdir]} {
261        ui_debug "Removing directory: ${subdir}"
262        if {[catch {delete $subdir} result]} {
263            ui_debug "$::errorInfo"
264            ui_error "$result"
265        }
266        catch {file delete $logpath}
267    } else {
268        ui_debug "No log directory found to remove at ${logpath}"
269    }                   
270    return 0
271}
272
273proc portclean::clean_archive {args} {
274    global subport ports_version_glob portdbpath
275
276    # Define archive destination directory, target filename, regex for archive name
277    set archivepath [file join $portdbpath incoming]
278
279    if {[info exists ports_version_glob]} {
280        # Match all possible archive variants that match the version
281        # glob specified by the user.
282        set fileglob "$subport-[option ports_version_glob]*.*.*.*"
283    } else {
284        # Match all possible archives for this port.
285        set fileglob "$subport-*_*.*.*.*"
286    }
287
288    # Remove the archive files
289    set count 0
290    foreach dir [list $archivepath ${archivepath}/verified] {
291        set archivelist [glob -nocomplain -directory $dir $fileglob]
292        foreach path $archivelist {
293            # Make sure file is truly an archive file for this port, and not
294            # an accidental match with some other file that might exist. Also
295            # delete anything ending in .TMP since those are incomplete and
296            # thus can't be checked and aren't useful anyway.
297            set archivetype [string range [file extension $path] 1 end]
298            if {[file isfile $path] && ($archivetype eq "TMP"
299                || [extract_archive_metadata $path $archivetype portname] == $subport)} {
300                ui_debug "Removing archive: $path"
301                if {[catch {delete $path} result]} {
302                    ui_debug "$::errorInfo"
303                    ui_error "$result"
304                }
305                if {[file isfile ${path}.rmd160]} {
306                    ui_debug "Removing archive signature: ${path}.rmd160"
307                    if {[catch {delete ${path}.rmd160} result]} {
308                        ui_debug "$::errorInfo"
309                        ui_error "$result"
310                    }
311                }
312                incr count
313            }
314        }
315    }
316    if {$count > 0} {
317        ui_debug "$count archive(s) removed."
318    } else {
319        ui_debug "No archives found to remove at $archivepath"
320    }
321
322    return 0
323}
Note: See TracBrowser for help on using the repository browser.