[66020] branches/images-and-archives/base/src
blb at macports.org
blb at macports.org
Sun Apr 4 20:32:08 PDT 2010
Revision: 66020
http://trac.macports.org/changeset/66020
Author: blb at macports.org
Date: 2010-04-04 20:32:05 -0700 (Sun, 04 Apr 2010)
Log Message:
-----------
Reinstate registry1.0/portimage.tcl to try to simplify from-trunk merges
Modified Paths:
--------------
branches/images-and-archives/base/src/macports1.0/macports.tcl
branches/images-and-archives/base/src/port/port.tcl
branches/images-and-archives/base/src/registry1.0/Makefile
branches/images-and-archives/base/src/registry1.0/portuninstall.tcl
branches/images-and-archives/base/src/registry1.0/registry.tcl
Added Paths:
-----------
branches/images-and-archives/base/src/registry1.0/portimage.tcl
Modified: branches/images-and-archives/base/src/macports1.0/macports.tcl
===================================================================
--- branches/images-and-archives/base/src/macports1.0/macports.tcl 2010-04-05 02:45:58 UTC (rev 66019)
+++ branches/images-and-archives/base/src/macports1.0/macports.tcl 2010-04-05 03:32:05 UTC (rev 66020)
@@ -939,8 +939,8 @@
$workername alias registry_delete registry::delete_entry
$workername alias registry_exists registry::entry_exists
$workername alias registry_exists_for_name registry::entry_exists_for_name
- $workername alias registry_activate registry::activate
- $workername alias registry_deactivate registry::deactivate
+ $workername alias registry_activate portimage::activate
+ $workername alias registry_deactivate portimage::deactivate
$workername alias registry_register_deps registry::register_dependencies
$workername alias registry_fileinfo_for_index registry::fileinfo_for_index
$workername alias registry_fileinfo_for_file registry::fileinfo_for_file
@@ -2881,7 +2881,7 @@
# deactivate version_active
if {$is_dryrun eq "yes"} {
ui_msg "Skipping deactivate $portname @${version_active}_${revision_active} (dry run)"
- } elseif {[catch {registry::deactivate $portname ${version_active}_${revision_active}${variant_active} $optionslist} result]} {
+ } elseif {[catch {portimage::deactivate $portname ${version_active}_${revision_active}${variant_active} $optionslist} result]} {
global errorInfo
ui_debug "$errorInfo"
ui_error "Deactivating $portname ${version_active}_${revision_active} failed: $result"
Modified: branches/images-and-archives/base/src/port/port.tcl
===================================================================
--- branches/images-and-archives/base/src/port/port.tcl 2010-04-05 02:45:58 UTC (rev 66019)
+++ branches/images-and-archives/base/src/port/port.tcl 2010-04-05 03:32:05 UTC (rev 66020)
@@ -1950,7 +1950,7 @@
ui_error "Failed to install from image: $result"
return 1
} else {
- if {[catch {registry::activate $portinfo(name) "$portinfo(version)_$portinfo(revision)$portinfo(portvariants)" [array get options]} result] } {
+ if {[catch {portimage::activate $portinfo(name) "$portinfo(version)_$portinfo(revision)$portinfo(portvariants)" [array get options]} result] } {
ui_error "Failed to activate: $result"
return 1
}
@@ -1971,7 +1971,7 @@
}
foreachport $portlist {
if {![macports::global_option_isset ports_dryrun]} {
- if { [catch {registry::activate $portname [composite_version $portversion [array get variations]] [array get options]} result] } {
+ if { [catch {portimage::activate $portname [composite_version $portversion [array get variations]] [array get options]} result] } {
global errorInfo
ui_debug "$errorInfo"
break_softcontinue "port activate failed: $result" 1 status
@@ -1992,7 +1992,7 @@
}
foreachport $portlist {
if {![macports::global_option_isset ports_dryrun]} {
- if { [catch {registry::deactivate $portname [composite_version $portversion [array get variations]] [array get options]} result] } {
+ if { [catch {portimage::deactivate $portname [composite_version $portversion [array get variations]] [array get options]} result] } {
global errorInfo
ui_debug "$errorInfo"
break_softcontinue "port deactivate failed: $result" 1 status
Modified: branches/images-and-archives/base/src/registry1.0/Makefile
===================================================================
--- branches/images-and-archives/base/src/registry1.0/Makefile 2010-04-05 02:45:58 UTC (rev 66019)
+++ branches/images-and-archives/base/src/registry1.0/Makefile 2010-04-05 03:32:05 UTC (rev 66020)
@@ -1,6 +1,6 @@
INSTALLDIR= ${DESTDIR}${datadir}/macports/Tcl/registry1.0
-SRCS= registry.tcl registry_autoconf.tcl receipt_flat.tcl portuninstall.tcl
+SRCS= registry.tcl registry_autoconf.tcl receipt_flat.tcl portimage.tcl portuninstall.tcl
include ../../Mk/macports.autoconf.mk
Copied: branches/images-and-archives/base/src/registry1.0/portimage.tcl (from rev 50646, branches/images-and-archives/base/src/registry1.0/portimage.tcl)
===================================================================
--- branches/images-and-archives/base/src/registry1.0/portimage.tcl (rev 0)
+++ branches/images-and-archives/base/src/registry1.0/portimage.tcl 2010-04-05 03:32:05 UTC (rev 66020)
@@ -0,0 +1,420 @@
+# portimage.tcl
+# $Id$
+#
+# Copyright (c) 2004 Will Barton <wbb4 at opendarwin.org>
+# Copyright (c) 2002 Apple Computer, Inc.
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions
+# are met:
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer.
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+# 3. Neither the name of Apple Computer, Inc. nor the names of its contributors
+# may be used to endorse or promote products derived from this software
+# without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+# POSSIBILITY OF SUCH DAMAGE.
+#
+
+package provide portimage 1.0
+
+package require registry 1.0
+package require macports 1.0
+package require Pextlib 1.0
+
+set UI_PREFIX "--> "
+
+#
+# Port Images are installations of the destroot of a port archived into a
+# tbz file.
+# They allow the user to install multiple versions of the same port, treating
+# each revision and each different combination of variants as a "version".
+#
+# From there, the user can "activate" a port image. This extracts the port's
+# files from the tbz into ${prefix}. Directories are created.
+# Activation checks the registry's file_map for any files which conflict with
+# other "active" ports, and will not overwrite the links to the those files.
+# The conflicting port must be deactivated first.
+#
+# The user can also "deactivate" an active port. This will remove all the
+# port's files from ${prefix}, and if any directories are empty, remove them
+# as well. It will also remove all of the references of the files from the
+# registry's file_map.
+#
+
+namespace eval portimage {
+
+variable force
+namespace export force
+
+# Activate a "Port Image"
+proc activate {name v optionslist} {
+ global macports::prefix macports::registry.path UI_PREFIX env
+ global macports::portimagefilepath
+ array set options $optionslist
+ variable force
+
+ if {[info exists options(ports_force)] && [string equal -nocase $options(ports_force) "yes"] } {
+ set force 1
+ } else {
+ set force 0
+ }
+
+ set ilist [_check_registry $name $v]
+ # set name again since the one we were passed may not have had the correct case
+ set name [lindex $ilist 0]
+ set version [lindex $ilist 1]
+ set revision [lindex $ilist 2]
+ set variants [lindex $ilist 3]
+ set epoch [lindex $ilist 5]
+ set macport_filename [macports::getportimagename_from_port_info $name $epoch $version $revision $variants]
+ set macport_file [file join ${macports::portimagefilepath} $name $macport_filename]
+ if {![file exists $macport_file]} {
+ return -code error "Image error: Can't find image file $macport_file"
+ }
+
+ # if another version of this port is active, deactivate it first
+ set ilist [registry::installed $name]
+ if { [llength $ilist] > 1 } {
+ foreach i $ilist {
+ set iname [lindex $i 0]
+ set iversion [lindex $i 1]
+ set irevision [lindex $i 2]
+ set ivariants [lindex $i 3]
+ set iactive [lindex $i 4]
+ if { ![string equal ${iversion}_${irevision}${ivariants} ${version}_${revision}${variants}] && $iactive == 1 } {
+ deactivate $iname ${iversion}_${irevision}${ivariants} $optionslist
+ }
+ }
+ }
+
+ if {$v != ""} {
+ ui_msg "$UI_PREFIX [format [msgcat::mc "Activating %s @%s"] $name $v]"
+ } else {
+ ui_msg "$UI_PREFIX [format [msgcat::mc "Activating %s"] $name]"
+ }
+
+ set ref [registry::open_entry $name $version $revision $variants]
+
+ if { [registry::property_retrieve $ref active] != 0 } {
+ return -code error "Image error: ${name} @${version}_${revision}${variants} is already active."
+ }
+
+ set contents [registry::property_retrieve $ref contents]
+
+ set imagefiles {}
+ foreach content_element $contents {
+ lappend imagefiles [lindex $content_element 0]
+ }
+
+ set extractdir [mkdtemp [file join [macports::gettmpdir] mpextractXXXXXXXX]]
+ set startpwd [pwd]
+ try {
+ if {[catch {cd $extractdir} err]} {
+ throw MACPORTS $err
+ }
+ if {[catch {set tarcmd [macports::findBinary tar]} err]} {
+ throw MACPORTS $err
+ }
+ if {[catch {set bzipcmd [macports::findBinary bzip2]} err]} {
+ throw MACPORTS $err
+ }
+ if {[catch {system "$tarcmd -xf $macport_file files.tar.bz2"} err]} {
+ throw MACPORTS $err
+ }
+ if {[catch {system "$bzipcmd -dc files.tar.bz2 | $tarcmd -xpvf -"} err]} {
+ throw MACPORTS $err
+ }
+ _activate_contents $name $imagefiles $extractdir
+ registry::property_store $ref active 1
+ registry::write_entry $ref
+
+ registry::register_bulk_files $contents $name
+ } catch {* errorCode errorMessage} {
+ ui_error $errorMessage
+ } finally {
+ cd $startpwd
+ file delete -force $extractdir
+ }
+}
+
+proc deactivate {name v optionslist} {
+ global UI_PREFIX
+ array set options $optionslist
+ variable force
+
+ if {[info exists options(ports_force)] && [string equal -nocase $options(ports_force) "yes"] } {
+ set force 1
+ } else {
+ set force 0
+ }
+
+ set ilist [registry::active $name]
+ if { [llength $ilist] > 1 } {
+ return -code error "Registry error: Please specify the name of the port."
+ } else {
+ set ilist [lindex $ilist 0]
+ }
+ # set name again since the one we were passed may not have had the correct case
+ set name [lindex $ilist 0]
+ set version [lindex $ilist 1]
+ set revision [lindex $ilist 2]
+ set variants [lindex $ilist 3]
+ set fqversion ${version}_${revision}${variants}
+
+ if {$v != ""} {
+ ui_msg "$UI_PREFIX [format [msgcat::mc "Deactivating %s @%s"] $name $v]"
+ } else {
+ ui_msg "$UI_PREFIX [format [msgcat::mc "Deactivating %s"] $name]"
+ }
+
+ if { $v != "" && ![string equal ${fqversion} $v] } {
+ return -code error "Active version of $name is not $v but ${fqversion}."
+ }
+
+ set ref [registry::open_entry $name $version $revision $variants]
+
+ if { [registry::property_retrieve $ref active] != 1 } {
+ return -code error "Image error: ${name} @${fqversion} is not active."
+ }
+
+ set imagefiles [registry::port_registered $name]
+
+ _deactivate_contents $name $imagefiles
+
+ registry::open_file_map
+ foreach file $imagefiles {
+ registry::unregister_file $file
+ }
+ registry::write_file_map
+ registry::close_file_map
+
+ registry::property_store $ref active 0
+
+ registry::write_entry $ref
+
+}
+
+proc _check_registry {name v} {
+ global UI_PREFIX
+
+ set ilist [registry::installed $name $v]
+ if { [string equal $v ""] } {
+ if { [llength $ilist] > 1 } {
+ # set name again since the one we were passed may not have had the correct case
+ set name [lindex [lindex $ilist 0] 0]
+ ui_msg "$UI_PREFIX [msgcat::mc "The following versions of $name are currently installed:"]"
+ foreach i $ilist {
+ set iname [lindex $i 0]
+ set iversion [lindex $i 1]
+ set irevision [lindex $i 2]
+ set ivariants [lindex $i 3]
+ set iactive [lindex $i 4]
+ if { $iactive == 0 } {
+ ui_msg "$UI_PREFIX [format [msgcat::mc " %s @%s_%s%s"] $iname $iversion $irevision $ivariants]"
+ } elseif { $iactive == 1 } {
+ ui_msg "$UI_PREFIX [format [msgcat::mc " %s @%s_%s%s (active)"] $iname $iversion $irevision $ivariants]"
+ }
+ }
+ return -code error "Registry error: Please specify the full version as recorded in the port registry."
+ } else {
+ return [lindex $ilist 0]
+ }
+ } else {
+ return [lindex $ilist 0]
+ }
+ return -code error "Registry error: No port of $name installed."
+}
+
+proc _activate_file {srcfile dstfile} {
+ # Don't recursively copy directories
+ if { [file isdirectory $srcfile] && [file type $srcfile] != "link" } {
+ # Don't do anything if the directory already exists.
+ if { ![file isdirectory $dstfile] } {
+ file mkdir $dstfile
+ # fix attributes on the directory.
+ eval file attributes {$dstfile} [file attributes $srcfile]
+ # set mtime on installed element
+ file mtime $dstfile [file mtime $srcfile]
+ }
+ } else {
+ file rename $srcfile $dstfile
+ }
+}
+
+proc _activate_list {flist extractdir} {
+ foreach file $flist {
+ ui_debug "activating [file type ${extractdir}${file}]: $file"
+ _activate_file ${extractdir}${file} $file
+ }
+}
+
+proc _activate_contents {name imagefiles extractdir} {
+ variable force
+ global macports::prefix
+
+ set files [list]
+ set timestamp [clock seconds]
+
+ # This is big and hairy and probably could be done better.
+ # First, we need to check the source file, make sure it exists
+ # Then we remove the $extractdir from the path of the file in the contents
+ # list and check to see if that file exists
+ # Last, if the file exists, and belongs to another port, and force is set
+ # we remove the file from the file_map, take ownership of it, and
+ # clobber it
+ foreach file $imagefiles {
+ set srcfile ${extractdir}${file}
+
+ # To be able to install links, we test if we can lstat the file to figure
+ # out if the source file exists (file exists will return false for symlinks on
+ # files that do not exist)
+ if { [catch {file lstat $srcfile dummystatvar}] } {
+ return -code error "Image error: Source file $srcfile does not appear to exist (cannot lstat it). Unable to activate port $name."
+ }
+
+ set port [registry::file_registered $file]
+
+ if { $port != 0 && $force != 1 && $port != $name } {
+ if {[catch {mportlookup $port} result]} {
+ global errorInfo
+ ui_debug "$errorInfo"
+ return -code error "port lookup failed: $result"
+ }
+ array set portinfo [lindex $result 1]
+ if {[info exists portinfo(replaced_by)] && [lsearch -exact -nocase $portinfo(replaced_by) $name] != -1} {
+ deactivate $port "" ""
+ } else {
+ return -code error "Image error: $file is being used by the active $port port. Please deactivate this port first, or use 'port -f activate $name' to force the activation."
+ }
+ } elseif { [file exists $file] && $force != 1 } {
+ return -code error "Image error: $file already exists and does not belong to a registered port. Unable to activate port $name."
+ } elseif { $force == 1 && [file exists $file] || $port != 0 } {
+ set bakfile ${file}.mp_${timestamp}
+
+ if {[file exists $file]} {
+ ui_warn "File $file already exists. Moving to: $bakfile."
+ file rename -force $file $bakfile
+ }
+
+ if { $port != 0 } {
+ set bakport [registry::file_registered $file]
+ registry::unregister_file $file
+ if {[file exists $bakfile]} {
+ registry::register_file $bakfile $bakport
+ }
+ }
+ }
+
+ # Split out the filename's subpaths and add them to the imagefile list.
+ # We need directories first to make sure they will be there before
+ # links. However, because file mkdir creates all parent directories,
+ # we don't need to have them sorted from root to subpaths. We do need,
+ # nevertheless, all sub paths to make sure we'll set the directory
+ # attributes properly for all directories.
+ set directory [file dirname $file]
+ while { [lsearch -exact $files $directory] == -1 } {
+ lappend files $directory
+ set directory [file dirname $directory]
+ }
+
+ # Also add the filename to the imagefile list.
+ lappend files $file
+ }
+ registry::write_file_map
+
+ # Sort the list in forward order, removing duplicates.
+ # Since the list is sorted in forward order, we're sure that directories
+ # are before their elements.
+ # We don't have to do this as mentioned above, but it makes the
+ # debug output of activate make more sense.
+ set theList [lsort -increasing -unique $files]
+
+ # Activate it, and catch errors so we can roll-back
+ if { [catch {set files [_activate_list $theList $extractdir] } result] } {
+ ui_debug "Activation failed, rolling back."
+ _deactivate_contents $name $imagefiles
+ return -code error $result
+ }
+}
+
+proc _deactivate_file {dstfile} {
+ if { [file type $dstfile] == "link" } {
+ ui_debug "deactivating link: $dstfile"
+ file delete -- $dstfile
+ } elseif { [file isdirectory $dstfile] } {
+ # 0 item means empty.
+ if { [llength [readdir $dstfile]] == 0 } {
+ ui_debug "deactivating directory: $dstfile"
+ file delete -- $dstfile
+ } else {
+ ui_debug "$dstfile is not empty"
+ }
+ } else {
+ ui_debug "deactivating file: $dstfile"
+ file delete -- $dstfile
+ }
+}
+
+proc _deactivate_list {filelist} {
+ foreach file $filelist {
+ _deactivate_file $file
+ }
+}
+
+proc _deactivate_contents {name imagefiles} {
+ set files [list]
+
+ foreach file $imagefiles {
+ if { [file exists $file] || (![catch {file type $file}] && [file type $file] == "link") } {
+ # Normalize the file path to avoid removing the intermediate
+ # symlinks (remove the empty directories instead)
+ # Remark: paths in the registry may be not normalized.
+ # This is not really a problem and it is in fact preferable.
+ # Indeed, if I change the activate code to include normalized paths
+ # instead of the paths we currently have, users' registry won't
+ # match and activate will say that some file exists but doesn't
+ # belong to any port.
+ set theFile [file normalize $file]
+ lappend files $theFile
+
+ # Split out the filename's subpaths and add them to the image list as
+ # well. The realpath call is necessary because file normalize
+ # does not resolve symlinks on OS X < 10.6
+ set directory [realpath [file dirname $theFile]]
+ while { [lsearch -exact $files $directory] == -1 } {
+ lappend files $directory
+ set directory [file dirname $directory]
+ }
+ } else {
+ ui_debug "$file does not exist."
+ }
+ }
+
+ # Sort the list in reverse order, removing duplicates.
+ # Since the list is sorted in reverse order, we're sure that directories
+ # are after their elements.
+ set theList [lsort -decreasing -unique $files]
+
+ # Remove all elements.
+ if { [catch {_deactivate_list $theList} result] } {
+ return -code error $result
+ }
+}
+
+# End of portimage namespace
+}
Modified: branches/images-and-archives/base/src/registry1.0/portuninstall.tcl
===================================================================
--- branches/images-and-archives/base/src/registry1.0/portuninstall.tcl 2010-04-05 02:45:58 UTC (rev 66019)
+++ branches/images-and-archives/base/src/registry1.0/portuninstall.tcl 2010-04-05 03:32:05 UTC (rev 66020)
@@ -129,7 +129,7 @@
if {[info exists options(ports_dryrun)] && $options(ports_dryrun) == "yes"} {
ui_msg "For $portname @${version}_${revision}${variants}: skipping deactivate (dry run)"
} else {
- registry::deactivate $portname ${version}_${revision}${variants} $optionslist
+ portimage::deactivate $portname ${version}_${revision}${variants} $optionslist
}
}
Modified: branches/images-and-archives/base/src/registry1.0/registry.tcl
===================================================================
--- branches/images-and-archives/base/src/registry1.0/registry.tcl 2010-04-05 02:45:58 UTC (rev 66019)
+++ branches/images-and-archives/base/src/registry1.0/registry.tcl 2010-04-05 03:32:05 UTC (rev 66020)
@@ -33,18 +33,12 @@
package require macports 1.0
package require receipt_flat 1.0
+package require portimage 1.0
package require portuninstall 1.0
package require msgcat
-package require Pextlib 1.0
-set UI_PREFIX "---> "
-
namespace eval registry {
-variable force
-namespace export force
-
-
# Begin creating a new registry entry for the port version_revision+variant
# This process assembles the directory name and creates a receipt dlist
proc new_entry {name version {revision 0} {variants ""} {epoch 0} } {
@@ -391,380 +385,6 @@
return [${macports::registry.format}::write_dep_map $args]
}
-
-#
-# Port Images are installations of the destroot of a port archived into a
-# tbz file.
-# They allow the user to install multiple versions of the same port, treating
-# each revision and each different combination of variants as a "version".
-#
-# From there, the user can "activate" a port image. This extracts the port's
-# files from the tbz into ${prefix}. Directories are created.
-# Activation checks the registry's file_map for any files which conflict with
-# other "active" ports, and will not overwrite the links to the those files.
-# The conflicting port must be deactivated first.
-#
-# The user can also "deactivate" an active port. This will remove all the
-# port's files from ${prefix}, and if any directories are empty, remove them
-# as well. It will also remove all of the references of the files from the
-# registry's file_map.
-#
-
-# Activate a "Port Image"
-proc activate {name v optionslist} {
- global macports::prefix macports::registry.path UI_PREFIX env
- global macports::portimagefilepath
- array set options $optionslist
- variable force
-
- if {[info exists options(ports_force)] && [string equal -nocase $options(ports_force) "yes"] } {
- set force 1
- } else {
- set force 0
- }
-
- set ilist [_check_registry $name $v]
- # set name again since the one we were passed may not have had the correct case
- set name [lindex $ilist 0]
- set version [lindex $ilist 1]
- set revision [lindex $ilist 2]
- set variants [lindex $ilist 3]
- set epoch [lindex $ilist 5]
- set macport_filename [macports::getportimagename_from_port_info $name $epoch $version $revision $variants]
- set macport_file [file join ${macports::portimagefilepath} $name $macport_filename]
- if {![file exists $macport_file]} {
- return -code error "Image error: Can't find image file $macport_file"
- }
-
- # if another version of this port is active, deactivate it first
- set ilist [registry::installed $name]
- if { [llength $ilist] > 1 } {
- foreach i $ilist {
- set iname [lindex $i 0]
- set iversion [lindex $i 1]
- set irevision [lindex $i 2]
- set ivariants [lindex $i 3]
- set iactive [lindex $i 4]
- if { ![string equal ${iversion}_${irevision}${ivariants} ${version}_${revision}${variants}] && $iactive == 1 } {
- deactivate $iname ${iversion}_${irevision}${ivariants} $optionslist
- }
- }
- }
-
- if {$v != ""} {
- ui_msg "$UI_PREFIX [format [msgcat::mc "Activating %s @%s"] $name $v]"
- } else {
- ui_msg "$UI_PREFIX [format [msgcat::mc "Activating %s"] $name]"
- }
-
- set ref [registry::open_entry $name $version $revision $variants]
-
- if { [registry::property_retrieve $ref active] != 0 } {
- return -code error "Image error: ${name} @${version}_${revision}${variants} is already active."
- }
-
- set contents [registry::property_retrieve $ref contents]
-
- set imagefiles {}
- foreach content_element $contents {
- lappend imagefiles [lindex $content_element 0]
- }
-
- set extractdir [mkdtemp [file join [macports::gettmpdir] mpextractXXXXXXXX]]
- set startpwd [pwd]
- try {
- if {[catch {cd $extractdir} err]} {
- throw MACPORTS $err
- }
- if {[catch {set tarcmd [macports::findBinary tar]} err]} {
- throw MACPORTS $err
- }
- if {[catch {set bzipcmd [macports::findBinary bzip2]} err]} {
- throw MACPORTS $err
- }
- if {[catch {system "$tarcmd -xf $macport_file files.tar.bz2"} err]} {
- throw MACPORTS $err
- }
- if {[catch {system "$bzipcmd -dc files.tar.bz2 | $tarcmd -xpvf -"} err]} {
- throw MACPORTS $err
- }
- _activate_contents $name $imagefiles $extractdir
- registry::property_store $ref active 1
- registry::write_entry $ref
-
- registry::register_bulk_files $contents $name
- } catch {* errorCode errorMessage} {
- ui_error $errorMessage
- } finally {
- cd $startpwd
- file delete -force $extractdir
- }
-}
-
-proc deactivate {name v optionslist} {
- global UI_PREFIX
- array set options $optionslist
- variable force
-
- if {[info exists options(ports_force)] && [string equal -nocase $options(ports_force) "yes"] } {
- set force 1
- } else {
- set force 0
- }
-
- set ilist [registry::active $name]
- if { [llength $ilist] > 1 } {
- return -code error "Registry error: Please specify the name of the port."
- } else {
- set ilist [lindex $ilist 0]
- }
- # set name again since the one we were passed may not have had the correct case
- set name [lindex $ilist 0]
- set version [lindex $ilist 1]
- set revision [lindex $ilist 2]
- set variants [lindex $ilist 3]
- set fqversion ${version}_${revision}${variants}
-
- if {$v != ""} {
- ui_msg "$UI_PREFIX [format [msgcat::mc "Deactivating %s @%s"] $name $v]"
- } else {
- ui_msg "$UI_PREFIX [format [msgcat::mc "Deactivating %s"] $name]"
- }
-
- if { $v != "" && ![string equal ${fqversion} $v] } {
- return -code error "Active version of $name is not $v but ${fqversion}."
- }
-
- set ref [registry::open_entry $name $version $revision $variants]
-
- if { [registry::property_retrieve $ref active] != 1 } {
- return -code error "Image error: ${name} @${fqversion} is not active."
- }
-
- set imagefiles [registry::port_registered $name]
-
- _deactivate_contents $name $imagefiles
-
- registry::open_file_map
- foreach file $imagefiles {
- registry::unregister_file $file
- }
- registry::write_file_map
- registry::close_file_map
-
- registry::property_store $ref active 0
-
- registry::write_entry $ref
-
-}
-
-proc _check_registry {name v} {
- global UI_PREFIX
-
- set ilist [registry::installed $name $v]
- if { [string equal $v ""] } {
- if { [llength $ilist] > 1 } {
- # set name again since the one we were passed may not have had the correct case
- set name [lindex [lindex $ilist 0] 0]
- ui_msg "$UI_PREFIX [msgcat::mc "The following versions of $name are currently installed:"]"
- foreach i $ilist {
- set iname [lindex $i 0]
- set iversion [lindex $i 1]
- set irevision [lindex $i 2]
- set ivariants [lindex $i 3]
- set iactive [lindex $i 4]
- if { $iactive == 0 } {
- ui_msg "$UI_PREFIX [format [msgcat::mc " %s @%s_%s%s"] $iname $iversion $irevision $ivariants]"
- } elseif { $iactive == 1 } {
- ui_msg "$UI_PREFIX [format [msgcat::mc " %s @%s_%s%s (active)"] $iname $iversion $irevision $ivariants]"
- }
- }
- return -code error "Registry error: Please specify the full version as recorded in the port registry."
- } else {
- return [lindex $ilist 0]
- }
- } else {
- return [lindex $ilist 0]
- }
- return -code error "Registry error: No port of $name installed."
-}
-
-proc _activate_file {srcfile dstfile} {
- # Don't recursively copy directories
- if { [file isdirectory $srcfile] && [file type $srcfile] != "link" } {
- # Don't do anything if the directory already exists.
- if { ![file isdirectory $dstfile] } {
- file mkdir $dstfile
- # fix attributes on the directory.
- eval file attributes {$dstfile} [file attributes $srcfile]
- # set mtime on installed element
- file mtime $dstfile [file mtime $srcfile]
- }
- } else {
- file rename $srcfile $dstfile
- }
-}
-
-proc _activate_list {flist extractdir} {
- foreach file $flist {
- ui_debug "activating [file type ${extractdir}${file}]: $file"
- _activate_file ${extractdir}${file} $file
- }
-}
-
-proc _activate_contents {name imagefiles extractdir} {
- variable force
- global macports::prefix
-
- set files [list]
- set timestamp [clock seconds]
-
- # This is big and hairy and probably could be done better.
- # First, we need to check the source file, make sure it exists
- # Then we remove the $extractdir from the path of the file in the contents
- # list and check to see if that file exists
- # Last, if the file exists, and belongs to another port, and force is set
- # we remove the file from the file_map, take ownership of it, and
- # clobber it
- foreach file $imagefiles {
- set srcfile ${extractdir}${file}
-
- # To be able to install links, we test if we can lstat the file to figure
- # out if the source file exists (file exists will return false for symlinks on
- # files that do not exist)
- if { [catch {file lstat $srcfile dummystatvar}] } {
- return -code error "Image error: Source file $srcfile does not appear to exist (cannot lstat it). Unable to activate port $name."
- }
-
- set port [registry::file_registered $file]
-
- if { $port != 0 && $force != 1 && $port != $name } {
- if {[catch {mportlookup $port} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- return -code error "port lookup failed: $result"
- }
- array set portinfo [lindex $result 1]
- if {[info exists portinfo(replaced_by)] && [lsearch -exact -nocase $portinfo(replaced_by) $name] != -1} {
- deactivate $port "" ""
- } else {
- return -code error "Image error: $file is being used by the active $port port. Please deactivate this port first, or use 'port -f activate $name' to force the activation."
- }
- } elseif { [file exists $file] && $force != 1 } {
- return -code error "Image error: $file already exists and does not belong to a registered port. Unable to activate port $name."
- } elseif { $force == 1 && [file exists $file] || $port != 0 } {
- set bakfile ${file}.mp_${timestamp}
-
- if {[file exists $file]} {
- ui_warn "File $file already exists. Moving to: $bakfile."
- file rename -force $file $bakfile
- }
-
- if { $port != 0 } {
- set bakport [registry::file_registered $file]
- registry::unregister_file $file
- if {[file exists $bakfile]} {
- registry::register_file $bakfile $bakport
- }
- }
- }
-
- # Split out the filename's subpaths and add them to the imagefile list.
- # We need directories first to make sure they will be there before
- # links. However, because file mkdir creates all parent directories,
- # we don't need to have them sorted from root to subpaths. We do need,
- # nevertheless, all sub paths to make sure we'll set the directory
- # attributes properly for all directories.
- set directory [file dirname $file]
- while { [lsearch -exact $files $directory] == -1 } {
- lappend files $directory
- set directory [file dirname $directory]
- }
-
- # Also add the filename to the imagefile list.
- lappend files $file
- }
- registry::write_file_map
-
- # Sort the list in forward order, removing duplicates.
- # Since the list is sorted in forward order, we're sure that directories
- # are before their elements.
- # We don't have to do this as mentioned above, but it makes the
- # debug output of activate make more sense.
- set theList [lsort -increasing -unique $files]
-
- # Activate it, and catch errors so we can roll-back
- if { [catch {set files [_activate_list $theList $extractdir] } result] } {
- ui_debug "Activation failed, rolling back."
- _deactivate_contents $name $imagefiles
- return -code error $result
- }
-}
-
-proc _deactivate_file {dstfile} {
- if { [file type $dstfile] == "link" } {
- ui_debug "deactivating link: $dstfile"
- file delete -- $dstfile
- } elseif { [file isdirectory $dstfile] } {
- # 0 item means empty.
- if { [llength [readdir $dstfile]] == 0 } {
- ui_debug "deactivating directory: $dstfile"
- file delete -- $dstfile
- } else {
- ui_debug "$dstfile is not empty"
- }
- } else {
- ui_debug "deactivating file: $dstfile"
- file delete -- $dstfile
- }
-}
-
-proc _deactivate_list {filelist} {
- foreach file $filelist {
- _deactivate_file $file
- }
-}
-
-proc _deactivate_contents {name imagefiles} {
- set files [list]
-
- foreach file $imagefiles {
- if { [file exists $file] || (![catch {file type $file}] && [file type $file] == "link") } {
- # Normalize the file path to avoid removing the intermediate
- # symlinks (remove the empty directories instead)
- # Remark: paths in the registry may be not normalized.
- # This is not really a problem and it is in fact preferable.
- # Indeed, if I change the activate code to include normalized paths
- # instead of the paths we currently have, users' registry won't
- # match and activate will say that some file exists but doesn't
- # belong to any port.
- set theFile [file normalize $file]
- lappend files $theFile
-
- # Split out the filename's subpaths and add them to the image list as
- # well. The realpath call is necessary because file normalize
- # does not resolve symlinks on OS X < 10.6
- set directory [realpath [file dirname $theFile]]
- while { [lsearch -exact $files $directory] == -1 } {
- lappend files $directory
- set directory [file dirname $directory]
- }
- } else {
- ui_debug "$file does not exist."
- }
- }
-
- # Sort the list in reverse order, removing duplicates.
- # Since the list is sorted in reverse order, we're sure that directories
- # are after their elements.
- set theList [lsort -decreasing -unique $files]
-
- # Remove all elements.
- if { [catch {_deactivate_list $theList} result] } {
- return -code error $result
- }
-}
-
# End of registry namespace
}
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://lists.macosforge.org/pipermail/macports-changes/attachments/20100404/9f435323/attachment-0001.html>
More information about the macports-changes
mailing list