source: trunk/base/src/registry2.0/portimage.tcl @ 146730

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

ui_ask_singlechoice returns 0-based index instead of 1-based

Update proc _check_registry{} in portimage.tcl to return the
new 0-based index instead of using the old 1-based index.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 31.0 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# portimage.tcl
3# $Id: portimage.tcl 146730 2016-03-16 10:04:56Z ijackson@macports.org $
4#
5# Copyright (c) 2004-2005, 2007-2011 The MacPorts Project
6# Copyright (c) 2004 Will Barton <wbb4@opendarwin.org>
7# Copyright (c) 2002 Apple Inc.
8# All rights reserved.
9#
10# Redistribution and use in source and binary forms, with or without
11# modification, are permitted provided that the following conditions
12# are met:
13# 1. Redistributions of source code must retain the above copyright
14#    notice, this list of conditions and the following disclaimer.
15# 2. Redistributions in binary form must reproduce the above copyright
16#    notice, this list of conditions and the following disclaimer in the
17#    documentation and/or other materials provided with the distribution.
18# 3. Neither the name of Apple Inc. nor the names of its contributors
19#    may be used to endorse or promote products derived from this software
20#    without specific prior written permission.
21#
22# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
23# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
24# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
25# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
26# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
27# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
28# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
29# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
30# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
31# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
32# POSSIBILITY OF SUCH DAMAGE.
33#
34
35package provide portimage 2.0
36
37package require registry 1.0
38package require registry2 2.0
39package require registry_util 2.0
40package require macports 1.0
41package require Pextlib 1.0
42
43package require Tclx
44
45set UI_PREFIX "--> "
46
47# Port Images are installations of the destroot of a port into a compressed
48# tarball in ${macports::registry.path}/software/${name}.
49# They allow the user to install multiple versions of the same port, treating
50# each revision and each different combination of variants as a "version".
51#
52# From there, the user can "activate" a port image.  This extracts the port's
53# files from the image into the ${prefix}.  Directories are created.
54# Activation checks the registry's file_map for any files which conflict with
55# other "active" ports, and will not overwrite the links to the those files.
56# The conflicting port must be deactivated first.
57#
58# The user can also "deactivate" an active port.  This will remove all the
59# port's files from ${prefix}, and if any directories are empty, remove them
60# as well. It will also remove all of the references of the files from the
61# registry's file_map.
62
63
64namespace eval portimage {
65
66variable force 0
67variable noexec 0
68
69# takes a composite version spec rather than separate version,revision,variants
70proc activate_composite {name {v ""} {optionslist ""}} {
71    if {$v eq ""} {
72        return [activate $name "" "" 0 $optionslist]
73    } elseif {[registry::decode_spec $v version revision variants]} {
74        return [activate $name $version $revision $variants $optionslist]
75    }
76    throw registry::invalid "Registry error: Invalid version '$v' specified for ${name}. Please specify a version as recorded in the port registry."
77}
78
79# Activate a "Port Image"
80proc activate {name {version ""} {revision ""} {variants 0} {optionslist ""}} {
81    global macports::prefix macports::registry.path registry_open UI_PREFIX
82    array set options $optionslist
83    variable force
84    variable noexec
85
86    if {[info exists options(ports_force)] && [string is true -strict $options(ports_force)] } {
87        set force 1
88    }
89    if {[info exists options(ports_activate_no-exec)]} {
90        set noexec $options(ports_activate_no-exec)
91    }
92    if {![info exists registry_open]} {
93        registry::open [::file join ${macports::registry.path} registry registry.db]
94        set registry_open yes
95    }
96    set todeactivate [list]
97
98    registry::read {
99
100        set requested [_check_registry $name $version $revision $variants]
101        # set name again since the one we were passed may not have had the correct case
102        set name [$requested name]
103        set version [$requested version]
104        set revision [$requested revision]
105        set variants [$requested variants]
106        set specifier "${version}_${revision}${variants}"
107        set location [$requested location]
108
109        # if another version of this port is active, deactivate it first
110        set current [registry::entry installed $name]
111        foreach i $current {
112            if { $specifier ne "[$i version]_[$i revision][$i variants]" } {
113                lappend todeactivate $i
114            }
115        }
116
117        # this shouldn't be possible
118        if { [$requested installtype] ne "image" } {
119            return -code error "Image error: ${name} @${specifier} not installed as an image."
120        }
121        if {![::file isfile $location]} {
122            return -code error "Image error: Can't find image file $location"
123        }
124        if {[$requested state] eq "installed"} {
125            return -code error "Image error: ${name} @${specifier} is already active."
126        }
127    }
128    foreach a $todeactivate {
129        if {$noexec || ![registry::run_target $a deactivate [list ports_nodepcheck 1]]} {
130            deactivate $name [$a version] [$a revision] [$a variants] [list ports_nodepcheck 1]
131        }
132    }
133
134    ui_msg "$UI_PREFIX [format [msgcat::mc "Activating %s @%s"] $name $specifier]"
135
136    _activate_contents $requested
137}
138
139# takes a composite version spec rather than separate version,revision,variants
140proc deactivate_composite {name {v ""} {optionslist ""}} {
141    if {$v eq ""} {
142        return [deactivate $name "" "" 0 $optionslist]
143    } elseif {[registry::decode_spec $v version revision variants]} {
144        return [deactivate $name $version $revision $variants $optionslist]
145    }
146    throw registry::invalid "Registry error: Invalid version '$v' specified for ${name}. Please specify a version as recorded in the port registry."
147}
148
149proc deactivate {name {version ""} {revision ""} {variants 0} {optionslist ""}} {
150    global UI_PREFIX macports::registry.path registry_open
151    array set options $optionslist
152
153    if {[info exists options(ports_force)] && [string is true -strict $options(ports_force)] } {
154        # this not using the namespace variable is correct, since activate
155        # needs to be able to force deactivate independently of whether
156        # the activation is being forced
157        set force 1
158    } else {
159        set force 0
160    }
161    if {![info exists registry_open]} {
162        registry::open [::file join ${macports::registry.path} registry registry.db]
163        set registry_open yes
164    }
165
166    if {$name eq ""} {
167        throw registry::image-error "Registry error: Please specify the name of the port."
168    }
169    set ilist [registry::entry installed $name]
170    if { [llength $ilist] == 1 } {
171        set requested [lindex $ilist 0]
172    } else {
173        throw registry::image-error "Image error: port ${name} is not active."
174    }
175    # set name again since the one we were passed may not have had the correct case
176    set name [$requested name]
177    set specifier "[$requested version]_[$requested revision][$requested variants]"
178
179    if {$version ne "" && ($version != [$requested version] ||
180        ($revision ne "" && ($revision != [$requested revision] || $variants != [$requested variants])))} {
181        set v $version
182        if {$revision ne ""} {
183            append v _${revision}${variants}
184        }
185        return -code error "Active version of $name is not $v but ${specifier}."
186    }
187
188    if { [$requested installtype] ne "image" } {
189        return -code error "Image error: ${name} @${specifier} not installed as an image."
190    }
191    # this shouldn't be possible
192    if { [$requested state] ne "installed" } {
193        return -code error "Image error: ${name} @${specifier} is not active."
194    }
195       
196    if {![info exists options(ports_nodepcheck)] || ![string is true -strict $options(ports_nodepcheck)]} {
197        set retvalue [registry::check_dependents $requested $force "deactivate"]
198        if {$retvalue eq "quit"} {
199            return
200        }
201    }
202
203    ui_msg "$UI_PREFIX [format [msgcat::mc "Deactivating %s @%s"] $name $specifier]"
204       
205    _deactivate_contents $requested [$requested files] $force
206}
207
208proc _check_registry {name version revision variants} {
209    global UI_PREFIX
210
211    set searchkeys $name
212    set composite_spec ""
213    if {$version ne ""} {
214        lappend searchkeys $version
215        set composite_spec $version
216        # restriction imposed by underlying registry API (see entry.c):
217        # if a revision is specified, so must variants be
218        if {$revision ne ""} {
219            lappend searchkeys $revision $variants
220            append composite_spec _${revision}${variants}
221        }
222    }
223    set ilist [registry::entry imaged {*}$searchkeys]
224
225    if { [llength $ilist] > 1 } {
226        set portilist {}
227        set msg "The following versions of $name are currently installed:"
228        if {[macports::ui_isset ports_noninteractive]} {
229            ui_msg "$UI_PREFIX [msgcat::mc $msg]"
230        }
231        foreach i $ilist {
232            set iname [$i name]
233            set iversion [$i version]
234            set irevision [$i revision]
235            set ivariants [$i variants]
236            ##
237            # User Interaction Question
238            # Asking choice to select option in case of ambiguous activate
239            if {[info exists macports::ui_options(questions_singlechoice)]} {
240                if { [$i state] eq "installed" } {
241                    lappend portilist $iname@${iversion}_${irevision}${ivariants}(active)
242                } else {
243                    lappend portilist $iname@${iversion}_${irevision}${ivariants}
244                }
245            } else {
246                if { [$i state] eq "installed" } {
247                    ui_msg "$UI_PREFIX [format [msgcat::mc "    %s @%s_%s%s (active)"] $iname $iversion $irevision $ivariants]"
248                } else {
249                    ui_msg "$UI_PREFIX [format [msgcat::mc "    %s @%s_%s%s"] $iname $iversion $irevision $ivariants]"
250                }
251            }
252        }
253        if {[info exists macports::ui_options(questions_singlechoice)]} {
254            set retvalue [$macports::ui_options(questions_singlechoice) $msg "Choice_Q1" $portilist]
255            return [lindex $ilist $retvalue]
256        }
257        throw registry::invalid "Registry error: Please specify the full version as recorded in the port registry."
258    } elseif { [llength $ilist] == 1 } {
259        return [lindex $ilist 0]
260    }
261    if {$composite_spec ne ""} {
262        set composite_spec " @${composite_spec}"
263    }
264    throw registry::invalid "Registry error: ${name}${composite_spec} is not installed."
265}
266
267## Activates a file from an image into the filesystem. Deals with symlinks,
268## directories and files.
269##
270## @param [in] srcfile path to file in image
271## @param [in] dstfile path to activate file to
272## @return 1 if file needs to be explicitly deleted if we have to roll back, 0 otherwise
273proc _activate_file {srcfile dstfile} {
274    if {[catch {set filetype [::file type $srcfile]} result]} {
275        # this can happen if the archive was built on case-sensitive and we're case-insensitive
276        # we know any existing dstfile is ours because we checked for conflicts earlier
277        if {![catch {file type $dstfile}]} {
278            ui_debug "skipping case-conflicting file: $srcfile"
279            return 0
280        } else {
281            error $result
282        }
283    }
284    switch $filetype {
285        directory {
286            # Don't recursively copy directories
287            ui_debug "activating directory: $dstfile"
288            # Don't do anything if the directory already exists.
289            if { ![::file isdirectory $dstfile] } {
290                ::file mkdir $dstfile
291                # fix attributes on the directory.
292                if {[getuid] == 0} {
293                    ::file attributes $dstfile {*}[::file attributes $srcfile]
294                } else {
295                    # not root, so can't set owner/group
296                    ::file attributes $dstfile -permissions {*}[::file attributes $srcfile -permissions]
297                }
298                # set mtime on installed element
299                ::file mtime $dstfile [::file mtime $srcfile]
300            }
301            return 0
302        }
303        default {
304            ui_debug "activating file: $dstfile"
305            ::file rename $srcfile $dstfile
306            return 1
307        }
308    }
309}
310
311# extract an archive to a temporary location
312# returns: path to the extracted directory
313proc extract_archive_to_tmpdir {location} {
314    global macports::registry.path
315    set extractdir [mkdtemp [::file dirname $location]/mpextractXXXXXXXX]
316    set startpwd [pwd]
317
318    try {
319        if {[catch {cd $extractdir} err]} {
320            throw MACPORTS $err
321        }
322   
323        # clagged straight from unarchive... this really needs to be factored
324        # out, but it's a little tricky as the places where it's used run in
325        # different interpreter contexts with access to different packages.
326        set unarchive.cmd {}
327        set unarchive.pre_args {}
328        set unarchive.args {}
329        set unarchive.pipe_cmd ""
330        set unarchive.type [::file extension $location]
331        switch -regex ${unarchive.type} {
332            cp(io|gz) {
333                set pax "pax"
334                if {[catch {set pax [macports::findBinary $pax ${macports::autoconf::pax_path}]} errmsg] == 0} {
335                    ui_debug "Using $pax"
336                    set unarchive.cmd "$pax"
337                    if {[geteuid] == 0} {
338                        set unarchive.pre_args {-r -v -p e}
339                    } else {
340                        set unarchive.pre_args {-r -v -p p}
341                    }
342                    if {[regexp {z$} ${unarchive.type}]} {
343                        set unarchive.args {.}
344                        set gzip "gzip"
345                        if {[catch {set gzip [macports::findBinary $gzip ${macports::autoconf::gzip_path}]} errmsg] == 0} {
346                            ui_debug "Using $gzip"
347                            set unarchive.pipe_cmd "$gzip -d -c ${location} |"
348                        } else {
349                            ui_debug $errmsg
350                            throw MACPORTS "No '$gzip' was found on this system!"
351                        }
352                    } else {
353                        set unarchive.args "-f ${location} ."
354                    }
355                } else {
356                    ui_debug $errmsg
357                    throw MACPORTS "No '$pax' was found on this system!"
358                }
359            }
360            t(ar|bz|lz|xz|gz) {
361                set tar "tar"
362                if {[catch {set tar [macports::findBinary $tar ${macports::autoconf::tar_path}]} errmsg] == 0} {
363                    ui_debug "Using $tar"
364                    set unarchive.cmd "$tar"
365                    set unarchive.pre_args {-xvpf}
366                    if {[regexp {z2?$} ${unarchive.type}]} {
367                        set unarchive.args {-}
368                        if {[regexp {bz2?$} ${unarchive.type}]} {
369                            if {![catch {macports::binaryInPath lbzip2}]} {
370                                set gzip "lbzip2"
371                            } elseif {![catch {macports::binaryInPath pbzip2}]} {
372                                set gzip "pbzip2"
373                            } else {
374                                set gzip "bzip2"
375                            }
376                        } elseif {[regexp {lz$} ${unarchive.type}]} {
377                            set gzip "lzma"
378                        } elseif {[regexp {xz$} ${unarchive.type}]} {
379                            set gzip "xz"
380                        } else {
381                            set gzip "gzip"
382                        }
383                        if {[info exists macports::autoconf::${gzip}_path]} {
384                            set hint [set macports::autoconf::${gzip}_path]
385                        } else {
386                            set hint ""
387                        }
388                        if {[catch {set gzip [macports::findBinary $gzip $hint]} errmsg] == 0} {
389                            ui_debug "Using $gzip"
390                            set unarchive.pipe_cmd "$gzip -d -c ${location} |"
391                        } else {
392                            ui_debug $errmsg
393                            throw MACPORTS "No '$gzip' was found on this system!"
394                        }
395                    } else {
396                        set unarchive.args "${location}"
397                    }
398                } else {
399                    ui_debug $errmsg
400                    throw MACPORTS "No '$tar' was found on this system!"
401                }
402            }
403            xar {
404                set xar "xar"
405                if {[catch {set xar [macports::findBinary $xar ${macports::autoconf::xar_path}]} errmsg] == 0} {
406                    ui_debug "Using $xar"
407                    set unarchive.cmd "$xar"
408                    set unarchive.pre_args {-xvpf}
409                    set unarchive.args "${location}"
410                } else {
411                    ui_debug $errmsg
412                    throw MACPORTS "No '$xar' was found on this system!"
413                }
414            }
415            zip {
416                set unzip "unzip"
417                if {[catch {set unzip [macports::findBinary $unzip ${macports::autoconf::unzip_path}]} errmsg] == 0} {
418                    ui_debug "Using $unzip"
419                    set unarchive.cmd "$unzip"
420                    if {[geteuid] == 0} {
421                        set unarchive.pre_args {-oX}
422                    } else {
423                        set unarchive.pre_args {-o}
424                    }
425                    set unarchive.args "${location} -d ."
426                } else {
427                    ui_debug $errmsg
428                    throw MACPORTS "No '$unzip' was found on this system!"
429                }
430            }
431            default {
432                throw MACPORTS "Unsupported port archive type '${unarchive.type}'!"
433            }
434        }
435       
436        # and finally, reinvent command_exec
437        if {${unarchive.pipe_cmd} == ""} {
438            set cmdstring "${unarchive.cmd} ${unarchive.pre_args} ${unarchive.args}"
439        } else {
440            set cmdstring "${unarchive.pipe_cmd} ( ${unarchive.cmd} ${unarchive.pre_args} ${unarchive.args} )"
441        }
442        system $cmdstring
443    } catch {*} {
444        ::file delete -force $extractdir
445        throw
446    } finally {
447        cd $startpwd
448    }
449
450    return $extractdir
451}
452
453## Activates the contents of a port
454proc _activate_contents {port {imagefiles {}} {location {}}} {
455    variable force
456    variable noexec
457    global macports::prefix
458
459    set files [list]
460    set baksuffix .mp_[clock seconds]
461    set location [$port location]
462    set imagefiles [$port imagefiles]
463    set extracted_dir [extract_archive_to_tmpdir $location]
464
465    set backups [list]
466    # This is big and hairy and probably could be done better.
467    # First, we need to check the source file, make sure it exists
468    # Then we remove the $location from the path of the file in the contents
469    #  list  and check to see if that file exists
470    # Last, if the file exists, and belongs to another port, and force is set
471    #  we remove the file from the file_map, take ownership of it, and
472    #  clobber it
473    array set todeactivate {}
474    try {
475        registry::write {
476            foreach file $imagefiles {
477                set srcfile "${extracted_dir}${file}"
478
479                # To be able to install links, we test if we can lstat the file to
480                # figure out if the source file exists (file exists will return
481                # false for symlinks on files that do not exist)
482                if { [catch {::file lstat $srcfile dummystatvar}] } {
483                    throw registry::image-error "Image error: Source file $srcfile does not appear to exist (cannot lstat it).  Unable to activate port [$port name]."
484                }
485
486                set owner [registry::entry owner $file]
487
488                if {$owner != {} && $owner != $port} {
489                    # deactivate conflicting port if it is replaced_by this one
490                    set result [mportlookup [$owner name]]
491                    array unset portinfo
492                    array set portinfo [lindex $result 1]
493                    if {[info exists portinfo(replaced_by)] && [lsearch -regexp $portinfo(replaced_by) "(?i)^[$port name]\$"] != -1} {
494                        # we'll deactivate the owner later, but before activating our files
495                        set todeactivate($owner) yes
496                        set owner "replaced"
497                    }
498                }
499
500                if {$owner ne "replaced"} {
501                    if { [string is true -strict $force] } {
502                        # if we're forcing the activation, then we move any existing
503                        # files to a backup file, both in the filesystem and in the
504                        # registry
505                        if { ![catch {::file type $file}] } {
506                            set bakfile "${file}${baksuffix}"
507                            ui_warn "File $file already exists.  Moving to: $bakfile."
508                            ::file rename -force -- $file $bakfile
509                            lappend backups $file
510                        }
511                        if { $owner != {} } {
512                            $owner deactivate [list $file]
513                            $owner activate [list $file] [list "${file}${baksuffix}"]
514                        }
515                    } else {
516                        # if we're not forcing the activation, then we bail out if
517                        # we find any files that already exist, or have entries in
518                        # the registry
519                        if { $owner != {} && $owner != $port } {
520                            throw registry::image-error "Image error: $file is being used by the active [$owner name] port.  Please deactivate this port first, or use 'port -f activate [$port name]' to force the activation."
521                        } elseif { $owner == {} && ![catch {::file type $file}] } {
522                            throw registry::image-error "Image error: $file already exists and does not belong to a registered port.  Unable to activate port [$port name]. Use 'port -f activate [$port name]' to force the activation."
523                        }
524                    }
525                }
526
527                # Split out the filename's subpaths and add them to the
528                # imagefile list.
529                # We need directories first to make sure they will be there
530                # before links. However, because file mkdir creates all parent
531                # directories, we don't need to have them sorted from root to
532                # subpaths. We do need, nevertheless, all sub paths to make sure
533                # we'll set the directory attributes properly for all
534                # directories.
535                set directory [::file dirname $file]
536                while {$directory ni $files} {
537                    lappend files $directory
538                    set directory [::file dirname $directory]
539                }
540
541                # Also add the filename to the imagefile list.
542                lappend files $file
543            }
544        }
545
546        # deactivate ports replaced_by this one
547        foreach owner [array names todeactivate] {
548            if {$noexec || ![registry::run_target $owner deactivate [list ports_nodepcheck 1]]} {
549                deactivate [$owner name] "" "" 0 [list ports_nodepcheck 1]
550            }
551        }
552
553        # Sort the list in forward order, removing duplicates.
554        # Since the list is sorted in forward order, we're sure that
555        # directories are before their elements.
556        # We don't have to do this as mentioned above, but it makes the
557        # debug output of activate make more sense.
558        set files [lsort -increasing -unique $files]
559        set rollback_filelist {}
560
561        registry::write {
562            # Activate it, and catch errors so we can roll-back
563            try {
564                $port activate $imagefiles
565                foreach file $files {
566                    if {[_activate_file "${extracted_dir}${file}" $file] == 1} {
567                        lappend rollback_filelist $file
568                    }
569                }
570
571                # Recording that the port has been activated should be done
572                # here so that this information cannot be inconsistent with the
573                # state of the files on disk.
574                $port state installed
575            } catch {{POSIX SIG SIGINT} eCode eMessage} {
576                # Pressing ^C will (often?) print "^C" to the terminal; send
577                # a linebreak so our message appears after that.
578                ui_msg ""
579                ui_msg "Control-C pressed, rolling back, please wait."
580                # can't do it here since we're already inside a transaction
581                set deactivate_this yes
582                throw
583            } catch {{POSIX SIG SIGTERM} eCode eMessage} {
584                ui_msg "SIGTERM received, rolling back, please wait."
585                # can't do it here since we're already inside a transaction
586                set deactivate_this yes
587                throw
588            } catch {*} {
589                ui_debug "Activation failed, rolling back."
590                # can't do it here since we're already inside a transaction
591                set deactivate_this yes
592                throw
593            }
594        }
595    } catch {*} {
596        # This code must run to completion, or the installation might be left
597        # in an inconsistent state. We store the old signal handling state,
598        # block the critical signals and restore to the previous state instead
599        # of unblocking.
600        # Note that this still contains a race condition: A user could press ^C
601        # fast enough so that the second error arrives before the error is
602        # caught, re-thrown and re-caught here. As far as I can see, there's no
603        # easy way around this problem.
604        set osignals [signal get {TERM INT}]
605        try {
606            # Block signals to avoid inconsistiencies.
607            signal block {TERM INT}
608
609            # roll back activation of this port
610            if {[info exists deactivate_this]} {
611                _deactivate_contents $port $rollback_filelist yes yes
612            }
613            # if any errors occurred, move backed-up files back to their original
614            # locations, then rethrow the error. Transaction rollback will take care
615            # of this in the registry.
616            foreach file $backups {
617                ::file rename -force -- "${file}${baksuffix}" $file
618            }
619            # reactivate deactivated ports
620            foreach entry [array names todeactivate] {
621                if {[$entry state] eq "imaged" && ($noexec || ![registry::run_target $entry activate ""])} {
622                    activate [$entry name] [$entry version] [$entry revision] [$entry variants] [list ports_activate_no-exec $noexec]
623                }
624            }
625        } finally {
626            # We've completed all critical operations, re-enable the TERM and
627            # INT signals.
628            signal set $osignals
629        }
630
631        # remove temp image dir
632        ::file delete -force $extracted_dir
633        throw
634    }
635    ::file delete -force $extracted_dir
636}
637
638# These directories should not be removed during deactivation even if they are empty.
639# TODO: look into what other dirs should go here
640variable precious_dirs
641array set precious_dirs { /Library/LaunchDaemons 1 /Library/LaunchAgents 1 }
642
643proc _deactivate_file {dstfile} {
644    if {[catch {::file type $dstfile} filetype]} {
645        ui_debug "$dstfile does not exist"
646        return
647    }
648    if { $filetype eq "link" } {
649        ui_debug "deactivating link: $dstfile"
650        file delete -- $dstfile
651    } elseif { $filetype eq "directory" } {
652        # 0 item means empty.
653        if { [llength [readdir $dstfile]] == 0 } {
654            variable precious_dirs
655            if {![info exists precious_dirs($dstfile)]} {
656                ui_debug "deactivating directory: $dstfile"
657                ::file delete -- $dstfile
658            } else {
659                ui_debug "directory $dstfile does not belong to us"
660            }
661        } else {
662            ui_debug "$dstfile is not empty"
663        }
664    } else {
665        ui_debug "deactivating file: $dstfile"
666        ::file delete -- $dstfile
667    }
668}
669
670proc _deactivate_contents {port imagefiles {force 0} {rollback 0}} {
671    set files [list]
672
673    foreach file $imagefiles {
674        if { [::file exists $file] || (![catch {::file type $file}] && [::file type $file] eq "link") } {
675            # Normalize the file path to avoid removing the intermediate
676            # symlinks (remove the empty directories instead)
677            # Remark: paths in the registry may be not normalized.
678            # This is not really a problem and it is in fact preferable.
679            # Indeed, if I change the activate code to include normalized paths
680            # instead of the paths we currently have, users' registry won't
681            # match and activate will say that some file exists but doesn't
682            # belong to any port.
683            # The custom realpath proc is necessary because file normalize
684            # does not resolve symlinks on OS X < 10.6
685            set directory [realpath [::file dirname $file]]
686            lappend files [::file join $directory [::file tail $file]]
687
688            # Split out the filename's subpaths and add them to the image list
689            # as well.
690            while {$directory ni $files} {
691                lappend files $directory
692                set directory [::file dirname $directory]
693            }
694        } else {
695            ui_debug "$file does not exist."
696        }
697    }
698
699    # Sort the list in reverse order, removing duplicates.
700    # Since the list is sorted in reverse order, we're sure that directories
701    # are after their elements.
702    set files [lsort -decreasing -unique $files]
703
704    # Avoid interruptions while removing the files and updating the database to
705    # prevent inconsistencies from forming between filesystem and database.
706    set osignals [signal get {TERM INT}]
707
708    try {
709        # Block the TERM and INT signals to avoid being interrupted. Note that
710        # they might already be block at this point because
711        # _deactivate_contents might be called during rollback of
712        # _activate_contents, but because we're storing the old signal state
713        # and returning to that instead of unblocking it doesn't matter.
714        signal block {TERM INT}
715
716        # Remove all elements.
717        if {!$rollback} {
718            registry::write {
719                $port deactivate $imagefiles
720                foreach file $files {
721                    _deactivate_file $file
722                }
723
724                # Update the port's state in the same transaction as the file
725                # delete operations.
726                $port state imaged
727            }
728        } else {
729            foreach file $files {
730                _deactivate_file $file
731            }
732        }
733    } finally {
734        # restore the signal block state
735        signal set $osignals
736    }
737}
738
739# End of portimage namespace
740}
Note: See TracBrowser for help on using the repository browser.