source: trunk/base/src/registry2.0/portuninstall.tcl @ 64641

Last change on this file since 64641 was 64641, checked in by jmr@…, 11 years ago

fix multiple portuninstall namespace confusion

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 14.6 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# portuninstall.tcl
3# $Id: portuninstall.tcl 64641 2010-03-12 17:52:53Z jmr@macports.org $
4#
5# Copyright (c) 2002 - 2003 Apple Inc.
6# All rights reserved.
7#
8# Redistribution and use in source and binary forms, with or without
9# modification, are permitted provided that the following conditions
10# are met:
11# 1. Redistributions of source code must retain the above copyright
12#    notice, this list of conditions and the following disclaimer.
13# 2. Redistributions in binary form must reproduce the above copyright
14#    notice, this list of conditions and the following disclaimer in the
15#    documentation and/or other materials provided with the distribution.
16# 3. Neither the name of Apple Inc. nor the names of its contributors
17#    may be used to endorse or promote products derived from this software
18#    without specific prior written permission.
19#
20# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
21# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
22# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
23# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
24# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
25# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
26# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
27# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
28# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
29# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
30# POSSIBILITY OF SUCH DAMAGE.
31#
32
33package provide registry_uninstall 2.0
34
35package require registry 1.0
36package require registry2 2.0
37package require registry_util 2.0
38
39set UI_PREFIX "---> "
40
41namespace eval registry_uninstall {
42
43proc uninstall {portname {v ""} optionslist} {
44    global uninstall.force uninstall.nochecksum UI_PREFIX \
45           macports::registry.format macports::registry.installtype
46    array set options $optionslist
47
48    if {![info exists uninstall.force]} {
49        set uninstall.force no
50    }
51    # If global forcing is on, make it the same as a local force flag.
52    if {[info exists options(ports_force)] && [string is true -strict $options(ports_force)]} {
53        set uninstall.force yes
54    }
55    # check which registry API to use
56    set use_reg2 [string equal ${macports::registry.format} "receipt_sqlite"]
57
58    if {$use_reg2} {
59        if { [registry::decode_spec $v version revision variants] } {
60            set ilist [registry::entry imaged $portname $version $revision $variants]
61            set valid 1
62        } else {
63            set valid [string equal $v {}]
64            set ilist [registry::entry imaged $portname]
65        }
66    } else {
67        set ilist [registry::installed $portname $v]
68        set valid 1
69    }
70    if { [llength $ilist] > 1 } {
71        # set portname again since the one we were passed may not have had the correct case
72        if {$use_reg2} {
73            set portname [[lindex $ilist 0] name]
74        } else {
75            set portname [lindex [lindex $ilist 0] 0]
76        }
77        ui_msg "$UI_PREFIX [msgcat::mc "The following versions of $portname are currently installed:"]"
78        foreach i [portlist_sortint $ilist] {
79            if {$use_reg2} {
80                set ispec "[$i version]_[$i revision][$i variants]"
81                if { [string equal [$i state] installed] } {
82                    ui_msg "$UI_PREFIX [format [msgcat::mc "    %s @%s (active)"] [$i name] $ispec]"
83                } else {
84                    ui_msg "$UI_PREFIX [format [msgcat::mc "    %s @%s"] [$i name] $ispec]"
85                }
86            } else {
87                set iname [lindex $i 0]
88                set iversion [lindex $i 1]
89                set irevision [lindex $i 2]
90                set ivariants [lindex $i 3]
91                set iactive [lindex $i 4]
92                if { $iactive == 1 } {
93                    ui_msg "$UI_PREFIX [format [msgcat::mc "    %s @%s_%s%s (active)"] $iname $iversion $irevision $ivariants]"
94                } else {
95                    ui_msg "$UI_PREFIX [format [msgcat::mc "    %s @%s_%s%s"] $iname $iversion $irevision $ivariants]"
96                }
97            }
98        }
99        if { $valid } {
100            throw registry::invalid "Registry error: Please specify the full version as recorded in the port registry."
101        } else {
102            throw registry::invalid "Registry error: Invalid version specified. Please specify a version as recorded in the port registry."
103        }
104    } elseif { [llength $ilist] == 1 } {
105        if {$use_reg2} {
106            set port [lindex $ilist 0]
107            if {$v == ""} {
108                set v "[$port version]_[$port revision][$port variants]"
109            }
110        } else {
111            set version [lindex [lindex $ilist 0] 1]
112            set revision [lindex [lindex $ilist 0] 2]
113            set variants [lindex [lindex $ilist 0] 3]
114            set active [lindex [lindex $ilist 0] 4]
115            if {$v == ""} {
116                set v "${version}_${revision}${variants}"
117            }
118        }
119    } else {
120        throw registry::invalid "Registry error: $portname not registered as installed"
121    }
122
123    if {$use_reg2} {
124        # uninstall dependents if requested
125        if {[info exists options(ports_uninstall_follow-dependents)] && $options(ports_uninstall_follow-dependents) eq "yes"} {
126            foreach depport [$port dependents] {
127                # make sure it's still installed, since a previous dep uninstall may have removed it
128                if {[registry::entry exists $depport] && ([$depport state] == "imaged" || [$depport state] == "installed")} {
129                    set depname [$depport name]
130                    set depver "[$depport version]_[$depport revision][$depport variants]"
131                    registry_uninstall::uninstall $depname $depver [array get options]
132                }
133            }
134        } else {
135            # check its dependents
136            registry::check_dependents $port ${uninstall.force}
137        }
138        # if it's an image, deactivate it
139        if { [string equal [$port state] installed] } {
140            if {[info exists options(ports_dryrun)] && [string is true -strict $options(ports_dryrun)]} {
141                ui_msg "For $portname @${v}: skipping deactivate (dry run)"
142            } else {
143                portimage::deactivate $portname $v $optionslist
144            }
145        }
146    } else {
147        # registry1.0
148       
149        # determine if it's the only installed port with that name or not.
150        if {$v == ""} {
151            set nb_versions_installed 1
152        } else {
153            set ilist [registry::installed $portname ""]
154            set nb_versions_installed [llength $ilist]
155        }
156   
157        set ref [registry::open_entry $portname $version $revision $variants]
158   
159        # Check and make sure no ports depend on this one
160        registry::open_dep_map 
161        set deplist [registry::list_dependents $portname $version $revision $variants]
162        if { [llength $deplist] > 0 } {
163            set dl [list]
164            # Check the deps first
165            foreach dep $deplist { 
166                set depport [lindex $dep 2]
167                ui_debug "$depport depends on this port"
168                if {[registry::entry_exists_for_name $depport]} {
169                    lappend dl $depport
170                }
171            }
172            # Now see if we need to error
173            if { [llength $dl] > 0 } {
174                if {[info exists options(ports_uninstall_follow-dependents)] && $options(ports_uninstall_follow-dependents) eq "yes"} {
175                    foreach depport $dl {
176                        # make sure it's still installed, since a previous dep uninstall may have removed it
177                        if {[registry::entry_exists_for_name $depport]} {
178                            registry_uninstall::uninstall $depport "" [array get options]
179                        }
180                    }
181                } else {
182                    # will need to change this when we get version/variant dependencies
183                    if {$nb_versions_installed == 1 || $active == 1} {
184                        ui_msg "$UI_PREFIX [format [msgcat::mc "Unable to uninstall %s %s_%s%s, the following ports depend on it:"] $portname $version $revision $variants]"
185                        foreach depport $dl {
186                            ui_msg "$UI_PREFIX [format [msgcat::mc "    %s"] $depport]"
187                        }
188                        if { [string is true -strict ${uninstall.force}] } {
189                            ui_warn "Uninstall forced.  Proceeding despite dependencies."
190                        } else {
191                            return -code error "Please uninstall the ports that depend on $portname first."
192                        }
193                    }
194                }
195            }
196        }
197   
198        set installtype [registry::property_retrieve $ref installtype]
199        if { $installtype == "image" && [registry::property_retrieve $ref active] == 1} {
200            if {[info exists options(ports_dryrun)] && [string is true -strict $options(ports_dryrun)]} {
201                ui_msg "For $portname @${version}_${revision}${variants}: skipping deactivate (dry run)"
202            } else {
203                portimage::deactivate $portname ${version}_${revision}${variants} $optionslist
204            }
205        }
206    }
207
208    if {[info exists options(ports_dryrun)] && [string is true -strict $options(ports_dryrun)]} {
209        ui_msg "For $portname @${v}: skipping uninstall (dry run)"
210        return 0
211    }
212
213    ui_msg "$UI_PREFIX [format [msgcat::mc "Uninstalling %s @%s"] $portname $v]"
214
215    if {!$use_reg2} {
216        # Look to see if the port has registered an uninstall procedure
217        set uninstall [registry::property_retrieve $ref pkg_uninstall] 
218        if { $uninstall != 0 } {
219            if {![catch {eval [string map { \\n \n } $uninstall]} err]} {
220                ui_info "Executing pkg_uninstall procedure"
221                if {[catch {pkg_uninstall $portname "${version}_${revision}${variants}" } err]} {
222                    ui_error [format [msgcat::mc "Error executing pkg_uninstall procedure: %s"] $err]
223                }
224            } else {
225                global errorInfo
226                ui_debug "$errorInfo"
227                ui_error [format [msgcat::mc "Could not evaluate pkg_uninstall procedure: %s"] $err]
228            }
229        }
230   
231        # Remove the port from the dep_map if only one version was installed.
232        # This is a temporary fix for a deeper problem that is that the dependency
233        # map doesn't take the port version into account (but should).
234        # Fixing it means transitionning to a new dependency map format.
235        if {$nb_versions_installed == 1} {
236            registry::unregister_dependencies $portname
237        }
238    }
239
240    # Now look for a contents list
241    if {$use_reg2} {
242        # imagefiles gives the actual installed files in direct mode
243        set contents [$port imagefiles]
244        set imagedir [$port location]
245    } else {
246        set contents [registry::property_retrieve $ref contents]
247        if { $contents == "" } {
248            return -code error [msgcat::mc "Uninstall failed: Port has no contents entry"]
249        }
250    }
251    set bak_suffix ".mp_[clock seconds]"
252    set files [list]
253    foreach f $contents {
254        if {$use_reg2} {
255            set fname "${imagedir}${f}"
256            #set sum1 [$port md5sum $f]
257            # there's an md5 column in registry.files in the db, but
258            # no way to get or set it seems to be implemented
259            set sum1 NONE
260        } else {
261            set fname [lindex $f 0]
262            set md5index [lsearch -regex [lrange $f 1 end] MD5]
263            if {$md5index != -1} {
264                set sumx [lindex $f [expr $md5index + 1]]
265            } else {
266                # XXX There is no MD5 listed, set sumx to an
267                # empty list, causing the next conditional to
268                # return a checksum error
269                set sumx {}
270            }
271            set sum1 [lindex $sumx [expr [llength $sumx] - 1]]
272        }
273        if {![string match $sum1 NONE] && !([info exists uninstall.nochecksum] && [string is true -strict ${uninstall.nochecksum}]) } {
274            if {![catch {set sum2 [md5 $fname]}] && ![string match $sum1 $sum2]} {
275                ui_warn "$UI_PREFIX  [format [msgcat::mc "Original checksum does not match for %s, saving a copy to %s"] $fname ${fname}${bak_suffix}]"
276                catch {file copy $fname "${fname}${bak_suffix}"}
277            }
278        }
279       
280        set theFile [file normalize $fname]
281        if { [file exists $theFile] || (![catch {file type $theFile}] && [file type $theFile] == "link") } {
282            # Normalize the file path to avoid removing the intermediate
283            # symlinks (remove the empty directories instead)
284            lappend files $theFile
285
286            # Split out the filename's subpaths and add them to the
287            # list as well. The realpath call is necessary because file normalize
288            # does not resolve symlinks on OS X < 10.6
289            set directory [realpath [file dirname $theFile]]
290            while { [lsearch -exact $files $directory] == -1 } { 
291                lappend files $directory
292                set directory [file dirname $directory]
293            }
294        }
295    }
296
297    # Sort the list in reverse order, removing duplicates.
298    # Since the list is sorted in reverse order, we're sure that directories
299    # are after their elements.
300    set theList [lsort -decreasing -unique $files]
301
302    # Remove all elements.
303    _uninstall_list $theList
304
305    if {$use_reg2} {
306        registry::entry delete $port
307    } else {
308        ui_info "$UI_PREFIX [format [msgcat::mc "Uninstall is removing %s from the port registry."] $portname]"
309        registry::delete_entry $ref
310    }
311    return 0
312}
313
314proc _uninstall_file {dstfile} {
315    if { ![catch {set type [file type $dstfile]}] } {
316        if { $type == "link" } {
317            ui_debug "uninstalling link: $dstfile"
318            file delete -- $dstfile
319        } elseif { [file isdirectory $dstfile] } {
320            # 0 item means empty.
321            if { [llength [readdir $dstfile]] == 0 } {
322                ui_debug "uninstalling directory: $dstfile"
323                file delete -- $dstfile
324            } else {
325                ui_debug "$dstfile is not empty"
326            }
327        } else {
328            ui_debug "uninstalling file: $dstfile"
329            file delete -- $dstfile
330        }
331    } else {
332        ui_debug "skip missing file: $dstfile"
333    }
334}
335
336proc _uninstall_list {filelist} {
337    foreach file $filelist {
338        _uninstall_file $file
339    }
340}
341
342# End of registry_uninstall namespace
343}
Note: See TracBrowser for help on using the repository browser.