[63398] trunk/base
jmr at macports.org
jmr at macports.org
Wed Feb 3 16:46:02 PST 2010
Revision: 63398
http://trac.macports.org/changeset/63398
Author: jmr at macports.org
Date: 2010-02-03 16:46:00 -0800 (Wed, 03 Feb 2010)
Log Message:
-----------
merge registry1.0 code into registry2.0
Modified Paths:
--------------
trunk/base/configure
trunk/base/configure.ac
trunk/base/doc/macports.conf.in
trunk/base/portmgr/freebsd/pkg-plist
trunk/base/src/Makefile.in
trunk/base/src/macports1.0/macports.tcl
trunk/base/src/registry2.0/Makefile
trunk/base/src/registry2.0/portimage.tcl
trunk/base/src/registry2.0/portuninstall.tcl
Added Paths:
-----------
trunk/base/src/registry2.0/receipt_flat.tcl
trunk/base/src/registry2.0/registry.tcl
trunk/base/src/registry2.0/registry_autoconf.tcl.in
Removed Paths:
-------------
trunk/base/src/registry1.0/receipt_flat.tcl
trunk/base/src/registry1.0/registry.tcl
trunk/base/src/registry1.0/registry_autoconf.tcl.in
Property Changed:
----------------
trunk/base/src/registry2.0/
Modified: trunk/base/configure
===================================================================
--- trunk/base/configure 2010-02-04 00:37:32 UTC (rev 63397)
+++ trunk/base/configure 2010-02-04 00:46:00 UTC (rev 63398)
@@ -9329,7 +9329,7 @@
# Output
-ac_config_files="$ac_config_files Doxyfile Makefile Mk/macports.autoconf.mk doc/prefix.mtree doc/macosx.mtree doc/macports.conf portmgr/freebsd/Makefile src/Makefile src/macports1.0/macports_autoconf.tcl src/port1.0/port_autoconf.tcl src/registry1.0/registry_autoconf.tcl src/programs/Makefile src/macports1.0/macports_fastload.tcl setupenv.bash"
+ac_config_files="$ac_config_files Doxyfile Makefile Mk/macports.autoconf.mk doc/prefix.mtree doc/macosx.mtree doc/macports.conf portmgr/freebsd/Makefile src/Makefile src/macports1.0/macports_autoconf.tcl src/port1.0/port_autoconf.tcl src/registry2.0/registry_autoconf.tcl src/programs/Makefile src/macports1.0/macports_fastload.tcl setupenv.bash"
ac_config_files="$ac_config_files src/pkg_mkindex.sh"
@@ -10030,7 +10030,7 @@
"src/Makefile") CONFIG_FILES="$CONFIG_FILES src/Makefile" ;;
"src/macports1.0/macports_autoconf.tcl") CONFIG_FILES="$CONFIG_FILES src/macports1.0/macports_autoconf.tcl" ;;
"src/port1.0/port_autoconf.tcl") CONFIG_FILES="$CONFIG_FILES src/port1.0/port_autoconf.tcl" ;;
- "src/registry1.0/registry_autoconf.tcl") CONFIG_FILES="$CONFIG_FILES src/registry1.0/registry_autoconf.tcl" ;;
+ "src/registry2.0/registry_autoconf.tcl") CONFIG_FILES="$CONFIG_FILES src/registry2.0/registry_autoconf.tcl" ;;
"src/programs/Makefile") CONFIG_FILES="$CONFIG_FILES src/programs/Makefile" ;;
"src/macports1.0/macports_fastload.tcl") CONFIG_FILES="$CONFIG_FILES src/macports1.0/macports_fastload.tcl" ;;
"setupenv.bash") CONFIG_FILES="$CONFIG_FILES setupenv.bash" ;;
Modified: trunk/base/configure.ac
===================================================================
--- trunk/base/configure.ac 2010-02-04 00:37:32 UTC (rev 63397)
+++ trunk/base/configure.ac 2010-02-04 00:46:00 UTC (rev 63398)
@@ -397,7 +397,7 @@
src/Makefile
src/macports1.0/macports_autoconf.tcl
src/port1.0/port_autoconf.tcl
- src/registry1.0/registry_autoconf.tcl
+ src/registry2.0/registry_autoconf.tcl
src/programs/Makefile
src/macports1.0/macports_fastload.tcl
setupenv.bash
Modified: trunk/base/doc/macports.conf.in
===================================================================
--- trunk/base/doc/macports.conf.in 2010-02-04 00:37:32 UTC (rev 63397)
+++ trunk/base/doc/macports.conf.in 2010-02-04 00:46:00 UTC (rev 63398)
@@ -11,7 +11,6 @@
portdbpath @localstatedir_expanded@/macports
# Type of storage to use for the port registry information, "flat" or "sqlite"
-# NOTE: sqlite not yet supported.
#portdbformat flat
# Type of installation to do for ports, "direct" or "image". See macports.conf(5) and online documentation.
Modified: trunk/base/portmgr/freebsd/pkg-plist
===================================================================
--- trunk/base/portmgr/freebsd/pkg-plist 2010-02-04 00:37:32 UTC (rev 63397)
+++ trunk/base/portmgr/freebsd/pkg-plist 2010-02-04 00:46:00 UTC (rev 63398)
@@ -49,12 +49,14 @@
share/macports/Tcl/port1.0/porttest.tcl
share/macports/Tcl/port1.0/porttrace.tcl
share/macports/Tcl/port1.0/portutil.tcl
-share/macports/Tcl/registry1.0/pkgIndex.tcl
-share/macports/Tcl/registry1.0/portimage.tcl
-share/macports/Tcl/registry1.0/portuninstall.tcl
-share/macports/Tcl/registry1.0/receipt_flat.tcl
-share/macports/Tcl/registry1.0/registry.tcl
-share/macports/Tcl/registry1.0/registry_autoconf.tcl
+share/macports/Tcl/registry2.0/pkgIndex.tcl
+share/macports/Tcl/registry2.0/portimage.tcl
+share/macports/Tcl/registry2.0/portuninstall.tcl
+share/macports/Tcl/registry2.0/receipt_flat.tcl
+share/macports/Tcl/registry2.0/registry.so
+share/macports/Tcl/registry2.0/registry.tcl
+share/macports/Tcl/registry2.0/registry_autoconf.tcl
+share/macports/Tcl/registry2.0/registry_util.tcl
var/macports/.tclpackage
@unexec /bin/rm -f %D/var/macports/.mprename
@dirrm var/macports/receipts
@@ -67,7 +69,7 @@
@dirrm share/macports/resources/port1.0
@dirrm share/macports/resources
@dirrm share/macports/Tcl/tclobjc1.0
- at dirrm share/macports/Tcl/registry1.0
+ at dirrm share/macports/Tcl/registry2.0
@dirrm share/macports/Tcl/port1.0
@dirrm share/macports/Tcl/pextlib1.0
@dirrm share/macports/Tcl/package1.0
Modified: trunk/base/src/Makefile.in
===================================================================
--- trunk/base/src/Makefile.in 2010-02-04 00:37:32 UTC (rev 63397)
+++ trunk/base/src/Makefile.in 2010-02-04 00:46:00 UTC (rev 63398)
@@ -4,7 +4,6 @@
port1.0 \
package1.0 \
pextlib1.0 \
- registry1.0 \
registry2.0 \
darwintracelib1.0
SUBDIR= ${TCLPKG} port programs
Modified: trunk/base/src/macports1.0/macports.tcl
===================================================================
--- trunk/base/src/macports1.0/macports.tcl 2010-02-04 00:37:32 UTC (rev 63397)
+++ trunk/base/src/macports1.0/macports.tcl 2010-02-04 00:46:00 UTC (rev 63398)
@@ -590,9 +590,6 @@
# Format for receipts, can currently be either "flat" or "sqlite"
if {[info exists portdbformat]} {
- if { $portdbformat == "sqlite" } {
- return -code error "SQLite is not yet supported for registry storage."
- }
set registry.format receipt_${portdbformat}
} else {
set registry.format receipt_flat
Deleted: trunk/base/src/registry1.0/receipt_flat.tcl
===================================================================
--- trunk/base/src/registry1.0/receipt_flat.tcl 2010-02-04 00:37:32 UTC (rev 63397)
+++ trunk/base/src/registry1.0/receipt_flat.tcl 2010-02-04 00:46:00 UTC (rev 63398)
@@ -1,864 +0,0 @@
-# receipt_flat.tcl
-# $Id$
-#
-# Copyright (c) 2004 Will Barton <wbb4 at opendarwin.org>
-# Copyright (c) 2004 Paul Guyot, The MacPorts Project.
-# 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 receipt_flat 1.0
-
-package require macports 1.0
-package require Pextlib 1.0
-
-##
-# Receipts Code supporting flat-files
-##
-namespace eval receipt_flat {
-
-# receipt_lastref is the last attributed index of receipts.
-variable receipt_lastref -1
-# maps port name,version,variants to the corresponding receipt ref
-variable ref_index
-
-##
-#
-# Create a new entry and return its reference number.
-# The reference number allows us to retrieve the receipt array.
-proc new_entry {} {
- variable receipt_lastref
- incr receipt_lastref
-
- variable receipt_$receipt_lastref
- array set receipt_$receipt_lastref {}
-
- return $receipt_lastref
-}
-
-##
-#
-# Get the path to the receipt in HEAD format.
-# Remark: this code doesn't work for some ports.
-# That's why we moved to the new path format in the first place.
-#
-# portname the name of the port.
-# portversion the version for this port, 0 if unknown.
-# return the path to the file or "" if the file couldn't be found.
-proc get_head_entry_receipt_path {portname portversion} {
- global macports::registry.path
-
- # regex match case
- if {$portversion == 0} {
- set x [glob -nocomplain -directory [file join ${macports::registry.path} receipts] -- ${portname}-*]
- if {[string length $x]} {
- set matchfile [lindex $x 0]
- # Remove trailing .bz2, if any.
- regexp {(.*)\.bz2$} $matchfile match matchfile
- } else {
- set matchfile ""
- }
- } else {
- set matchfile [file join ${macports::registry.path} receipts ${portname}-${portversion}]
- }
-
- # Might as well bail out early if no file to match
- if {![string length $matchfile]} {
- return ""
- }
-
- if {[file exists $matchfile] || [file exists ${matchfile}.bz2]} {
- return $matchfile
- }
- return ""
-}
-
-##
-#
-# Open an existing entry and return its reference number.
-proc open_entry {name {version ""} {revision 0} {variants ""}} {
- global macports::registry.installtype
- global macports::registry.path
- variable ref_index
-
- # if this entry is already open, just return the reference
- if {[info exists ref_index($name,$version,$revision,$variants)]} {
- return $ref_index($name,$version,$revision,$variants)
- }
-
- set receipt_path [file join ${macports::registry.path} receipts ${name}]
-
- # If the receipt path ${name} doesn't exist, then the receipt probably is
- # in the old HEAD format.
- if { ![file isdirectory $receipt_path] } {
- set receipt_file [get_head_entry_receipt_path $name $version]
-
- if {![string length $receipt_file]} {
- if { $version != "" } {
- return -code error "Registry error: ${name} @${version}_${revision}${variants} not registered as installed."
- } else {
- return -code error "Registry error: ${name} not registered as installed."
- }
- }
-
- # Extract the version from the path.
- if { $version == "" } {
- set theFileName [file tail $receipt_file]
- regexp "^$name-(.*)\$" $theFileName match version
- }
- } else {
- # If version wasn't specified, find out the version number. This will
- # depend on which installtype mode we're in, "direct" or "image"
- if { $version == "" } {
- # xxx: If we're in image mode, we really should have had the
- # version given to us. How should we handle this?
- set x [glob -nocomplain -directory ${receipt_path} *]
- if { [string length $x] } {
- set v [lindex [file split [lindex $x 0]] end]
- regexp {([-_a-zA-Z0-9\.]+)_([0-9]*)([+-_a-zA-Z0-9]*)$} $v match version revision variants
- } else {
- return -code error "Registry error: ${name} not registered as installed."
- }
- }
-
- if { ![entry_exists $name $version $revision $variants] } {
- return -code error "Registry error: ${name} @${version}_${revision}${variants} not registered as installed."
- }
-
- set receipt_path [file join ${macports::registry.path} receipts ${name} ${version}_${revision}${variants}]
-
- set receipt_file [file join ${receipt_path} receipt]
- }
-
- if { [file exists ${receipt_file}.bz2] && [file exists ${registry::autoconf::bzip2_path}] } {
- set receipt_file ${receipt_file}.bz2
- set receipt_contents [exec ${registry::autoconf::bzip2_path} -d -c ${receipt_file}]
- } elseif { [file exists ${receipt_file}] } {
- set receipt_handle [open ${receipt_file} r]
- set receipt_contents [read $receipt_handle]
- close $receipt_handle
- } else {
- return -code error "Registry error: receipt for ${name} @${version}_${revision}${variants} seems to be compressed, but bzip2 couldn't be found."
- }
-
- set ref [new_entry]
- variable receipt_$ref
-
- # Determine the format of the receipt.
- if {[string match "# Format: var value ...*" $receipt_contents]} {
- # This is old HEAD format.
- # We convert it and we save it.
- # tell the user
- ui_msg "Converting receipt for $name-$version to new format"
-
- convert_entry_from_HEAD $name $version $revision $variants $receipt_contents $ref
-
- # move the old receipt
- set convertedDirPath [file join ${macports::registry.path} receipts_converted]
- file mkdir $convertedDirPath
- file rename -- $receipt_file $convertedDirPath
- } elseif {[string match "# Version: *" $receipt_contents]} {
- # This is new format
- if {![string match "# Version: 1.0*" $receipt_contents]} {
- return -code error "Registry error: receipt ${name} @${version}_${revision}${variants} is in an unknown format (version too new?)."
- }
-
- # Remove any line starting with #
- while {[regexp "(^|\n)#.*\n(.*)\$" $receipt_contents match foo receipt_contents]} {}
- if {[catch {array set receipt_$ref $receipt_contents} rcpterr]} {
- ui_error "Malformed receipt for ${name} @${version}_${revision}${variants}"
- ui_error "receipt_contents = '$receipt_contents'"
- error $rcpterr
- }
- } else {
- # This is old Images format
-
- # Iterate on the elements of $receipt_contents and add them to the list.
- foreach pair $receipt_contents {
- array set receipt_[set ref] $pair
- }
- }
-
- set ref_index($name,$version,$revision,$variants) $ref
-
- return $ref
-}
-
-##
-#
-# Convert an entry from HEAD old format.
-# HEAD old format is a file in the key,value format with key and values being on the
-# same line separated with a space.
-# This typically is read with an options-like approach.
-# This conversion routine also appends the contents to the file map.
-#
-# name the name of the port to convert.
-# version the version of the port to convert.
-# revision the revision of the port to convert (probably inaccurate).
-# variants the variants of the port to convert (idem).
-# receipt_contents the content of the old receipt file.
-# ref reference of the target receipt array where the content must be put.
-proc convert_entry_from_HEAD {name version revision variants receipt_contents ref} {
- variable receipt_$ref
-
- # First set default value for stuff that aren't in the receipt.
- array set receipt_[set ref] [list name $name]
- array set receipt_[set ref] [list version $version]
- array set receipt_[set ref] [list revision $revision]
- array set receipt_[set ref] [list variants $variants]
- array set receipt_[set ref] [list installtype direct]
- array set receipt_[set ref] [list receipt_f receipt_flat]
- array set receipt_[set ref] [list active 1]
-
- # Then start a new interpreter to read the content of the portfile.
- interp create theConverterInterpreter
- # Just ignore prefix.
- interp eval theConverterInterpreter "proc prefix {args} {\n\
- }"
- # Also ignore run_depends.
- interp eval theConverterInterpreter "proc run_depends {args} {\n\
- }"
- interp eval theConverterInterpreter "proc categories {args} {\n\
- global theConvertedReceipt\n\
- array set theConvertedReceipt \[list categories \$args\]\n\
- }"
- interp eval theConverterInterpreter "proc description {args} {\n\
- global theConvertedReceipt\n\
- array set theConvertedReceipt \[list description \$args\]\n\
- }"
- interp eval theConverterInterpreter "proc long_description {args} {\
- global theConvertedReceipt\n\
- array set theConvertedReceipt \[list long_description \$args\]\n\
- }"
- interp eval theConverterInterpreter "proc homepage {args} {\n\
- global theConvertedReceipt\n\
- array set theConvertedReceipt \[list homepage \$args\]\n\
- }"
- # contents already is a list.
- interp eval theConverterInterpreter "proc contents {args} {\n\
- variable contents\n\
- set contents \[lindex \$args 0\]\n\
- }"
- interp eval theConverterInterpreter "array set theConvertedReceipt {}"
- interp eval theConverterInterpreter "variable contents"
- interp eval theConverterInterpreter $receipt_contents
- array set receipt_$ref [interp eval theConverterInterpreter "array get theConvertedReceipt"]
- set contents [interp eval theConverterInterpreter "set contents"]
- interp delete theConverterInterpreter
-
- # Append the contents list to the file map (only the files).
- set theActualContents [list]
- foreach file $contents {
- if {[llength $file]} {
- set theFilePath [lindex $file 0]
- if {[file isfile $theFilePath]} {
- set previousPort [file_registered $theFilePath]
- if {$previousPort != 0} {
- ui_warn "Conflict detected for file $theFilePath between $previousPort and $name."
- }
- if {[catch {register_file $theFilePath $name}]} {
- ui_warn "An error occurred while adding $theFilePath to the file_map database."
- }
- } elseif {![file exists $theFilePath]} {
- ui_warn "Port $name refers to $theFilePath which doesn't exist."
- }
- lappend theActualContents $file
- } else {
- ui_warn "Port $name contents list includes an empty element."
- }
- }
-
- property_store $ref contents $theActualContents
-
- # Save the file_map afterwards
- write_file_map
- close_file_map
-
- # Save the entry to new format.
- write_entry $ref $name $version $revision $variants
-}
-
-##
-#
-# Write the entry that was previously created.
-#
-# ref the reference number of the entry.
-# name the name of the port.
-# version the version of the port.
-# variants the variants of the port.
-proc write_entry {ref name version {revision 0} {variants ""}} {
- global macports::registry.installtype
- variable receipt_$ref
-
- set receipt_contents [array get receipt_$ref]
-
- set receipt_path [file join ${macports::registry.path} receipts ${name} ${version}_${revision}${variants}]
- set receipt_file [file join ${receipt_path} receipt]
-
- if { ![file isdirectory ${receipt_path}] } {
- file mkdir ${receipt_path}
- }
-
- set receipt_handle [open ${receipt_file}.tmp w 0644]
- puts $receipt_handle "# Version: 1.0"
- puts $receipt_handle $receipt_contents
- close $receipt_handle
-
- if { [file exists ${receipt_file}] } {
- file delete -force -- "${receipt_file}"
- } elseif { [file exists ${receipt_file}.bz2] } {
- file delete -force -- "${receipt_file}.bz2"
- }
-
- file rename -force -- "${receipt_file}.tmp" "${receipt_file}"
-
- if { [file exists ${receipt_file}] && [file exists ${registry::autoconf::bzip2_path}] && ![info exists registry.nobzip] } {
- system "${registry::autoconf::bzip2_path} -f ${receipt_file}"
- }
-
- return 1
-}
-
-# Check to see if an entry exists
-proc entry_exists {name version {revision 0} {variants ""}} {
- global macports::registry.path
-
- set receipt_path [file join ${macports::registry.path} receipts ${name} ${version}_${revision}${variants}]
- set receipt_file [file join ${receipt_path} receipt]
-
- if { [file exists $receipt_file] } {
- return 1
- } elseif { [file exists ${receipt_file}.bz2] } {
- return 1
- }
-
- return 0
-}
-
-# Check to see if any entry exists for the given port name
-proc entry_exists_for_name {name} {
- global macports::registry.path
-
- set receipt_path [file join ${macports::registry.path} receipts ${name}]
-
- if {[llength [glob -nocomplain -directory $receipt_path */receipt{,.bz2}]] > 0} {
- return 1
- }
-
- return 0
-}
-
-##
-#
-# Store a property to a receipt that was loaded in memory.
-# This replaces any property that had the same key previously in the receipt.
-#
-# ref reference number for the receipt.
-# property key for the property to store.
-# value value for the property to store.
-proc property_store {ref property value} {
- variable receipt_$ref
-
- array set receipt_[set ref] [list $property $value]
-
- return 1
-}
-
-##
-#
-# Retrieve a property from a receipt that was loaded in memory.
-#
-# ref reference number for the receipt.
-# property key for the property to retrieve.
-#
-proc property_retrieve {ref property} {
- variable receipt_$ref
-
- set theCouple [array get receipt_[set ref] $property]
- if {[llength $theCouple] != 2} {
- return 0
- } else {
- return [lindex $theCouple 1]
- }
-}
-
-# Delete an entry
-proc delete_entry {name version {revision 0} {variants ""}} {
- global macports::registry.path
- variable ref_index
-
- # if the entry is loaded, purge it
- if {[info exists ref_index($name,$version,$revision,$variants)]} {
- set ref $ref_index($name,$version,$revision,$variants)
- variable receipt_${ref}
- array unset receipt_${ref}
- array unset ref_index "$name,$version,$revision,$variants"
- }
-
- set receipt_path [file join ${macports::registry.path} receipts ${name} ${version}_${revision}${variants}]
- if { [file exists ${receipt_path}] } {
- # remove port receipt directory
- ui_debug "deleting directory: ${receipt_path}"
- file delete -force -- ${receipt_path}
- # remove port receipt parent directory (if empty)
- set receipt_dir [file join ${macports::registry.path} receipts ${name}]
- if { [file isdirectory ${receipt_dir}] } {
- # 0 item means empty.
- if { [llength [readdir ${receipt_dir}]] == 0 } {
- ui_debug "deleting directory: ${receipt_dir}"
- file delete -force -- ${receipt_dir}
- } else {
- ui_debug "${receipt_dir} is not empty"
- }
- }
- return 1
- } else {
- return 0
- }
-}
-
-# Return all installed ports
-#
-# If version is "", return all ports of that version.
-# Otherwise, return only ports that exactly match this version.
-# What we call version here is version_revision+variants.
-# Note: at some point we need to change these APIs and support something
-# like selecting on the version or selecting variants in any order.
-proc installed {{name ""} {version ""}} {
- global macports::registry.path
-
- set query_path [file join ${macports::registry.path} receipts]
-
- if { $name == "" } {
- set query_path [file join ${query_path} *]
- if { $version == "" } {
- set query_path [file join ${query_path} *]
- }
- # [PG] Huh?
- } else {
- # We want to be case-insensitive but case-preserving, so the name gets
- # returned with the correct case even if it's wrong when given. To get the
- # correct case on a case-insensitive FS, we have to list the directory and
- # compare against each entry.
- set name_path [file join ${query_path} *]
- set name_entries [glob -nocomplain -types d ${name_path}]
- foreach entry $name_entries {
- set basename [file tail $entry]
- if {[string equal -nocase $basename $name]} {
- set name $basename
- break
- }
- }
- set query_path [file join ${query_path} ${name}]
- if { $version != "" } {
- set query_path [file join ${query_path} ${version}]
- } else {
- set query_path [file join ${query_path} *]
- }
- }
-
- set x [glob -nocomplain -types d ${query_path}]
- set rlist [list]
- foreach p $x {
- if {![file isfile [file join $p receipt.bz2]] && ![file isfile [file join $p receipt]]} {
- continue
- }
- set plist [list]
- regexp {([-_a-zA-Z0-9\.]+)_([0-9]*)([+-_a-zA-Z0-9]*)$} [lindex [file split $p] end] match version revision variants
- lappend plist [lindex [file split $p] end-1]
- lappend plist $version
- lappend plist $revision
- lappend plist $variants
- lappend rlist $plist
- }
-
- # append the ports in old HEAD format.
- if { $name == "" } {
- set query_path [file join ${macports::registry.path} receipts *]
- } else {
- set query_path [file join ${macports::registry.path} receipts ${name}-*]
- }
- set receiptglob [glob -nocomplain -types f ${query_path}]
- foreach receipt_file $receiptglob {
- set theFileName [file tail $receipt_file]
-
- # Remark: these regexes do not always work.
- set theName ""
- if { $name == "" } {
- regexp {^(.*)-(.*)$} $theFileName match theName version
- } else {
- regexp "^($name)-(.*)\$" $theFileName match theName version
- }
-
- # Skip if the name is empty, i.e. if it didn't match.
- if {[string length $theName]} {
- set plist [list]
- lappend plist $theName
-
- # Remove .bz2 suffix, if present.
- regexp {^(.*)\.bz2$} $version match version
- lappend plist $version
- lappend plist 0
- lappend plist ""
- lappend rlist $plist
- }
- }
-
- return $rlist
-}
-
-# File Map stuff
-
-##
-# open the file map and store a reference to it into variable file_map.
-# convert from the old format if required.
-#
-proc open_file_map {{readonly 0}} {
- global macports::registry.path
- variable file_map
-
- set receipt_path [file join ${macports::registry.path} receipts]
- set map_file [file join ${receipt_path} file_map]
-
- # Don't reopen it (it actually would deadlock us), unless it was open r/o.
- # and we want it r/w.
- if { [info exists file_map] } {
- if { $readonly == 0 } {
- if {[filemap isreadonly file_map]} {
- filemap close file_map
- filemap open file_map ${map_file}.db
- }
- }
- return 0
- }
-
- set old_filemap [list]
-
- if { ![file exists ${map_file}.db] } {
- # Convert to new format
- if { [file exists ${map_file}.bz2] && [file exists ${registry::autoconf::bzip2_path}] } {
- set old_filemap [exec ${registry::autoconf::bzip2_path} -d -c ${map_file}.bz2]
- } elseif { [file exists $map_file] } {
- set map_handle [open ${map_file} r]
- set old_filemap [read $map_handle]
- close $map_handle
- }
- }
-
- if { [llength $old_filemap] > 0 } {
- # Translate from old format.
- # Open the map (new format)
- filemap open file_map ${map_file}.db
-
- # Tell the user.
- ui_msg "Converting file map to new format (this may take a while)"
-
- foreach f $old_filemap {
- filemap set file_map [lindex $f 0] [lindex $f 1]
- }
-
- # Save it afterwards.
- filemap save file_map
-
- # reopen it r/o if we wanted it r/o.
- } else {
- # open it directly
- if { $readonly == 1 } {
- filemap open file_map ${map_file}.db readonly
- } else {
- filemap open file_map ${map_file}.db
- }
- }
-
- return 0
-}
-
-##
-# determine if a file is registered in the file map, and if it is,
-# get its port.
-# open the file map if required.
-#
-# - file the file to test
-# return the 0 if the file is not registered, the name of the port otherwise.
-#
-proc file_registered {file} {
- variable file_map
-
- open_file_map 1
-
- if {[filemap exists file_map $file]} {
- return [filemap get file_map $file]
- } else {
- return 0
- }
-}
-
-##
-# determine if a port is registered in the file map, and if it is,
-# get its installed (activated) files.
-# convert the port if required.
-# open the file map if required.
-#
-# - port the port to test
-# return the 0 if the port is not registered, the list of its files otherwise.
-#
-proc port_registered {name} {
- # Trust the file map first.
- variable file_map
-
- open_file_map 1
-
- set files [filemap list file_map $name]
-
- if { [llength $files] > 0 } {
- return $files
- } else {
- # Is port installed?
- set matchingPorts [installed $name]
- if { [llength $matchingPorts] } {
- # Convert the port and retry.
- open_entry $name
-
- set files [filemap list file_map $name]
-
- return $files
- } else {
- return 0
- }
- }
-}
-
-##
-# register a file in the file map.
-# open the file map if required.
-#
-# - file the file to register
-# - port the port to associate with the file
-#
-proc register_file {file port} {
- variable file_map
-
- open_file_map
-
- if { [file type $file] == "link" } {
- ui_debug "Adding link to file_map: $file for: $port"
- } else {
- ui_debug "Adding file to file_map: $file for: $port"
- }
- filemap set file_map $file $port
-}
-
-##
-# register all the files in the list 'files' in the filemap.
-# open the file map if required.
-#
-# - files the list of files to register
-# - port the port to associate the files with
-#
-proc register_bulk_files {files port} {
- variable file_map
-
- open_file_map
-
- foreach f $files {
- set file [lindex $f 0]
- if { [file type $file] == "link" } {
- ui_debug "Adding link to file_map: $file for: $port"
- } else {
- ui_debug "Adding file to file_map: $file for: $port"
- }
- filemap set file_map $file $port
- }
-}
-
-##
-# unregister a file from the file map.
-# open the file map if required.
-#
-# - file the file to unregister
-#
-proc unregister_file {file} {
- variable file_map
-
- open_file_map
-
- ui_debug "Removing entry from file_map: $file"
- filemap unset file_map $file
-}
-
-##
-# save the file map to disk.
-# do not do anything if the file map wasn't open.
-#
-# always return 1
-#
-proc write_file_map {args} {
- variable file_map
-
- if { [info exists file_map] } {
- open_file_map
- filemap save file_map
- }
-
- return 1
-}
-
-##
-# close the file map.
-# important to do this so the lock is released.
-# do not do anything if the file map wasn't open.
-#
-proc close_file_map {args} {
- variable file_map
-
- if { [info exists file_map] } {
- filemap close file_map
- }
-}
-
-# Dependency Map Code
-proc open_dep_map {args} {
- global macports::registry.path
- variable dep_map
-
- set receipt_path [file join ${macports::registry.path} receipts]
-
- set map_file [file join ${receipt_path} dep_map]
-
- if { [file exists ${map_file}.bz2] && [file exists ${registry::autoconf::bzip2_path}] } {
- set dep_map [exec ${registry::autoconf::bzip2_path} -d -c ${map_file}.bz2]
- } elseif { [file exists ${map_file}] } {
- set map_handle [open ${map_file} r]
- set dep_map [read $map_handle]
- close $map_handle
- } else {
- set dep_map [list]
- }
- if { ![llength $dep_map] > 0 } {
- set dep_map [list]
- }
-}
-
-# List all ports this one depends on
-proc list_depends {name} {
- variable dep_map
- if { [llength $dep_map] < 1 && [info exists dep_map] } {
- open_dep_map
- }
- set rlist [list]
- foreach de $dep_map {
- if { $name == [lindex $de 2] } {
- lappend rlist $de
- }
- }
- return $rlist
-}
-
-# List all the ports that depend on this port
-proc list_dependents {name} {
- variable dep_map
- if { [llength $dep_map] < 1 && [info exists dep_map] } {
- open_dep_map
- }
- set rlist [list]
- foreach de $dep_map {
- if { $name == [lindex $de 0] } {
- lappend rlist $de
- }
- }
- return $rlist
-}
-
-proc register_dep {dep type port} {
- variable dep_map
- set newdep [list $dep $type $port]
- # slow, but avoids duplicate entries building up
- if {[lsearch -exact $dep_map $newdep] == -1} {
- lappend dep_map $newdep
- }
-}
-
-proc unregister_dep {dep type port} {
- variable dep_map
- set new_map [list]
- foreach de $dep_map {
- if { $de != [list $dep $type $port] } {
- lappend new_map $de
- }
- }
- set dep_map $new_map
-}
-
-# remove duplicate entries from the dep_map
-# (could be put there by older versions of MacPorts)
-proc clean_dep_map {args} {
- variable dep_map
- set new_map [list]
- set oldlen [llength $dep_map]
- ui_debug "Current dep_map has $oldlen entries"
- foreach de $dep_map {
- if {[lsearch -exact $new_map $de] == -1} {
- lappend new_map $de
- } else {
- ui_debug "Removing $de from dep_map"
- }
- }
- set dep_map $new_map
-
- set newlen [llength $dep_map]
- set diff [expr $oldlen - $newlen]
- ui_debug "New dep_map has $newlen entries"
- ui_info "Removed $diff duplicate entries from the dependency map"
-}
-
-proc write_dep_map {args} {
- global macports::registry.path
- variable dep_map
-
- set receipt_path [file join ${macports::registry.path} receipts]
-
- set map_file [file join ${receipt_path} dep_map]
-
- set map_handle [open ${map_file}.tmp w 0644]
- puts $map_handle $dep_map
- close $map_handle
-
- # don't both checking for presence, file delete doesn't error if file doesn't exist
- file delete -- ${map_file} ${map_file}.bz2
-
- file rename -- ${map_file}.tmp ${map_file}
-
- if { [file exists ${map_file}] && [file exists ${registry::autoconf::bzip2_path}] && ![info exists registry.nobzip] } {
- system "${registry::autoconf::bzip2_path} -f ${map_file}"
- }
-
- return 1
-}
-
-# End of receipt_flat namespace
-}
-
Deleted: trunk/base/src/registry1.0/registry.tcl
===================================================================
--- trunk/base/src/registry1.0/registry.tcl 2010-02-04 00:37:32 UTC (rev 63397)
+++ trunk/base/src/registry1.0/registry.tcl 2010-02-04 00:46:00 UTC (rev 63398)
@@ -1,396 +0,0 @@
-# registry.tcl
-#
-# 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 registry 1.0
-
-package require macports 1.0
-package require receipt_flat 1.0
-package require portimage 1.0
-package require portuninstall 1.0
-package require msgcat
-
-namespace eval registry {
-
-# 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} } {
- global macports::registry.path macports::registry.format macports::registry.installtype macports::prefix
-
-
- # Make sure we don't already have an entry in the Registry for this
- # port version_revision+variants
- if {![entry_exists $name $version $revision $variants] } {
-
- set ref [${macports::registry.format}::new_entry]
-
- property_store $ref name $name
- property_store $ref version $version
- property_store $ref revision $revision
- property_store $ref variants $variants
- property_store $ref epoch $epoch
- # Trick to have a portable GMT-POSIX epoch-based time.
- # (because we'll compare this with a file mtime).
- property_store $ref date [expr [clock scan now -gmt true] - [clock scan "1970-1-1 00:00:00" -gmt true]]
- property_store $ref installtype ${macports::registry.installtype}
- property_store $ref receipt_f ${macports::registry.format}
- if { ${macports::registry.installtype} == "image" } {
- set imagedir [file join ${macports::registry.path} software ${name} ${version}_${revision}${variants}]
- property_store $ref imagedir $imagedir
- property_store $ref active 0
- }
-
- return $ref
- } else {
- return -code error "Registry error: ${name} @${version}_${revision}${variants} already registered as installed. Please uninstall it first."
- }
-}
-
-# Check to see if an entry exists in the registry. This is passed straight
-# through to the receipts system
-proc entry_exists {name version {revision 0} {variants ""}} {
- global macports::registry.format
- return [${macports::registry.format}::entry_exists $name $version $revision $variants]
-}
-
-# Check to see if any entry exists in the registry for the given port name.
-proc entry_exists_for_name {name} {
- global macports::registry.format
- return [${macports::registry.format}::entry_exists_for_name $name]
-}
-
-# Close the registry... basically wrap the receipts systems's write process
-proc write_entry {ref} {
- global macports::registry.format
-
- set name [property_retrieve $ref name]
- set version [property_retrieve $ref version]
- set revision [property_retrieve $ref revision]
- set variants [property_retrieve $ref variants]
- set epoch [property_retrieve $ref epoch]
- set contents [property_retrieve $ref contents]
-
- ${macports::registry.format}::write_entry $ref $name $version $revision $variants
-
-}
-
-# Delete an entry from the registry.
-proc delete_entry {ref} {
- global macports::registry.format
-
- set name [property_retrieve $ref name]
- set version [property_retrieve $ref version]
- set revision [property_retrieve $ref revision]
- set variants [property_retrieve $ref variants]
-
- ${macports::registry.format}::delete_entry $name $version $revision $variants
-
-}
-
-# Open a registry entry.
-proc open_entry {name {version ""} {revision 0} {variants ""}} {
- global macports::registry.format
-
- return [${macports::registry.format}::open_entry $name $version $revision $variants]
-
-}
-
-# Store a property with the open registry entry.
-proc property_store {ref property value} {
- global macports::registry.format
- ${macports::registry.format}::property_store $ref $property $value
-}
-
-# Retrieve a property from the open registry entry.
-proc property_retrieve {ref property} {
- global macports::registry.format
- return [${macports::registry.format}::property_retrieve $ref $property]
-}
-
-# If only one version of the port is installed, this process returns that
-# version's parts. Otherwise, it lists the versions installed and exists.
-proc installed {{name ""} {version ""}} {
- global macports::registry.format
-
- set ilist [${macports::registry.format}::installed $name $version]
- set rlist [list]
-
- if { [llength $ilist] > 1 } {
- foreach installed $ilist {
- set iname [lindex $installed 0]
- set iversion [lindex $installed 1]
- set irevision [lindex $installed 2]
- set ivariants [lindex $installed 3]
- set iref [open_entry $iname $iversion $irevision $ivariants]
- set iactive [property_retrieve $iref active]
- set iepoch [property_retrieve $iref epoch]
- lappend rlist [list $iname $iversion $irevision $ivariants $iactive $iepoch]
- }
- } elseif { [llength $ilist] < 1 } {
- if { $name == "" } {
- return -code error "Registry error: No ports registered as installed."
- } else {
- if { $version == "" } {
- return -code error "Registry error: $name not registered as installed."
- } else {
- return -code error "Registry error: $name $version not registered as installed."
- }
- }
- } else {
- set iname [lindex [lindex $ilist 0] 0]
- set iversion [lindex [lindex $ilist 0] 1]
- set irevision [lindex [lindex $ilist 0] 2]
- set ivariants [lindex [lindex $ilist 0] 3]
- set iref [open_entry $iname $iversion $irevision $ivariants]
- set iactive [property_retrieve $iref active]
- set iepoch [property_retrieve $iref epoch]
- lappend rlist [list $iname $iversion $irevision $ivariants $iactive $iepoch]
- }
- return $rlist
-}
-
-# Return a list with the active version of a port (or the active versions of
-# all ports if name is "").
-proc active {{name ""}} {
- global macports::registry.format
-
- set ilist [${macports::registry.format}::installed $name]
- set rlist [list]
-
- if { [llength $ilist] > 0 } {
- foreach installed $ilist {
- set iname [lindex $installed 0]
- set iversion [lindex $installed 1]
- set irevision [lindex $installed 2]
- set ivariants [lindex $installed 3]
- set iref [open_entry $iname $iversion $irevision $ivariants]
- set iactive [property_retrieve $iref active]
- set iepoch [property_retrieve $iref epoch]
- if {$iactive} {
- lappend rlist [list $iname $iversion $irevision $ivariants $iactive $iepoch]
- }
- }
- }
-
- if { [llength $rlist] < 1 } {
- if { $name == "" } {
- return -code error "Registry error: No ports registered as active."
- } else {
- return -code error "Registry error: $name not registered as installed & active."
- }
- }
- return $rlist
-}
-
-proc location {portname portversion} {
- set ilist [registry::installed $portname $portversion]
-
- if { [llength $ilist] > 1 } {
- puts "The following versions of $portname 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 } {
- puts " $iname @${iversion}_${irevision}${ivariants}"
- } elseif { $iactive == 1 } {
- puts " $iname @${iversion}_${irevision}${ivariants} (active)"
- }
- }
- return -1
- } else {
- return [lindex $ilist 0]
- }
-}
-
-
-# File Map Code
-proc open_file_map {args} {
- global macports::registry.format
- return [${macports::registry.format}::open_file_map $args]
-}
-
-proc file_registered {file} {
- global macports::registry.format
- return [${macports::registry.format}::file_registered $file]
-}
-
-proc port_registered {name} {
- global macports::registry.format
- return [${macports::registry.format}::port_registered $name]
-}
-
-proc register_file {file port} {
- global macports::registry.format
- return [${macports::registry.format}::register_file $file $port]
-}
-
-proc register_bulk_files {files port} {
- global macports::registry.format
- open_file_map
- set r [${macports::registry.format}::register_bulk_files $files $port]
- write_file_map
- close_file_map
- return $r
-}
-
-proc unregister_file {file} {
- global macports::registry.format
- return [${macports::registry.format}::unregister_file $file]
-}
-
-proc write_file_map {args} {
- global macports::registry.format
- return [${macports::registry.format}::write_file_map $args]
-}
-
-proc close_file_map {args} {
- global macports::registry.format
- return [${macports::registry.format}::close_file_map $args]
-}
-
-# Dependency Map Code
-proc register_dependencies {deps name} {
-
- open_dep_map
- foreach dep $deps {
- # We expect the form type:regexp:port to come in, but we don't need to
- # store it that way in the dep map.
- set type [lindex [split $dep :] 0]
- set depport [lindex [split $dep :] end]
- register_dep $depport $type $name
- }
- write_dep_map
-}
-
-proc unregister_dependencies {name} {
-
- open_dep_map
- foreach dep [list_depends $name] {
- unregister_dep [lindex $dep 0] [lindex $dep 1] [lindex $dep 2]
- }
- write_dep_map
-}
-
-proc open_dep_map {args} {
- global macports::registry.format
- return [${macports::registry.format}::open_dep_map $args]
-}
-
-##
-#
-# From a file name, return a list representing data currently known about the file.
-# This list is a 6-tuple of the form:
-# 0: file path
-# 1: uid
-# 2: gid
-# 3: mode
-# 4: size
-# 5: md5 checksum information
-#
-# fname a path to a given file.
-# return a 6-tuple about this file.
-proc fileinfo_for_file {fname} {
- # Add the link to the registry, not the actual file.
- # (we won't store the md5 of the target of links since it's meaningless
- # and $statvar(mode) tells us that links are links).
- if {![catch {file lstat $fname statvar}]} {
- if {[file isfile $fname] && [file type $fname] != "link"} {
- if {[catch {md5 file $fname} md5sum] == 0} {
- # Create a line that matches md5(1)'s output
- # for backwards compatibility
- set line "MD5 ($fname) = $md5sum"
- return [list $fname $statvar(uid) $statvar(gid) $statvar(mode) $statvar(size) $line]
- }
- } else {
- return [list $fname $statvar(uid) $statvar(gid) $statvar(mode) $statvar(size) "MD5 ($fname) NONE"]
- }
- }
- return {}
-}
-
-##
-#
-# From a list of files, return a list of information concerning these files.
-# The information is obtained through fileinfo_for_file.
-#
-# flist the list of file to get information about.
-# return a list of 6-tuples described in fileinfo_for_file.
-proc fileinfo_for_index {flist} {
- global prefix
-
- set rval [list]
- foreach file $flist {
- if {[string index $file 0] != "/"} {
- set file [file join $prefix $file]
- }
- lappend rval [fileinfo_for_file $file]
- }
- return $rval
-}
-
-# List all ports this one depends on
-proc list_depends {name} {
- global macports::registry.format
- return [${macports::registry.format}::list_depends $name]
-}
-
-# List all the ports that depend on this port
-proc list_dependents {name} {
- global macports::registry.format
- return [${macports::registry.format}::list_dependents $name]
-}
-
-proc register_dep {dep type port} {
- global macports::registry.format
- return [${macports::registry.format}::register_dep $dep $type $port]
-}
-
-proc unregister_dep {dep type port} {
- global macports::registry.format
- return [${macports::registry.format}::unregister_dep $dep $type $port]
-}
-
-proc clean_dep_map {args} {
- global macports::registry.format
- return [${macports::registry.format}::clean_dep_map $args]
-}
-
-proc write_dep_map {args} {
- global macports::registry.format
- return [${macports::registry.format}::write_dep_map $args]
-}
-
-
-# End of registry namespace
-}
-
Deleted: trunk/base/src/registry1.0/registry_autoconf.tcl.in
===================================================================
--- trunk/base/src/registry1.0/registry_autoconf.tcl.in 2010-02-04 00:37:32 UTC (rev 63397)
+++ trunk/base/src/registry1.0/registry_autoconf.tcl.in 2010-02-04 00:46:00 UTC (rev 63398)
@@ -1,35 +0,0 @@
-# registry_autoconf.tcl.in
-# $Id$
-#
-# Copyright (c) 2007 Kevin Ballard <eridius at macports.org>
-# 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 registry 1.0
-
-namespace eval registry::autoconf {
- variable bzip2_path "@BZIP2@"
-}
Property changes on: trunk/base/src/registry2.0
___________________________________________________________________
Modified: svn:ignore
- registry.dylib
pkgIndex.tcl
+ pkgIndex.tcl
registry.dylib
registry_autoconf.tcl
Modified: trunk/base/src/registry2.0/Makefile
===================================================================
--- trunk/base/src/registry2.0/Makefile 2010-02-04 00:37:32 UTC (rev 63397)
+++ trunk/base/src/registry2.0/Makefile 2010-02-04 00:46:00 UTC (rev 63398)
@@ -1,6 +1,6 @@
# $Id$
-SRCS = registry_util.tcl portimage.tcl portuninstall.tcl
+SRCS = registry.tcl registry_autoconf.tcl registry_util.tcl receipt_flat.tcl portimage.tcl portuninstall.tcl
OBJS = registry.o util.o \
entry.o entryobj.o
#graph.o graphobj.o
@@ -19,6 +19,9 @@
${TCLSH} tests/entry.tcl ${SHLIB_NAME}
${TCLSH} tests/depends.tcl ${SHLIB_NAME}
+distclean:: clean
+ rm -f registry_autoconf.tcl
+
install:: all
$(INSTALL) -d -o ${DSTUSR} -g ${DSTGRP} -m ${DSTMODE} ${INSTALLDIR}
$(INSTALL) -o ${DSTUSR} -g ${DSTGRP} -m 444 ${SHLIB_NAME} ${INSTALLDIR}
Modified: trunk/base/src/registry2.0/portimage.tcl
===================================================================
--- trunk/base/src/registry2.0/portimage.tcl 2010-02-04 00:37:32 UTC (rev 63397)
+++ trunk/base/src/registry2.0/portimage.tcl 2010-02-04 00:46:00 UTC (rev 63398)
@@ -1,4 +1,4 @@
-# et:ts=4
+# -*- 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
# portimage.tcl
# $Id$
#
@@ -17,7 +17,7 @@
# 3. Neither the name of Apple 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
@@ -33,9 +33,10 @@
package provide portimage 2.0
-package require macports 1.0
+package require registry 1.0
package require registry2 2.0
package require registry_util 2.0
+package require macports 1.0
package require Pextlib 1.0
set UI_PREFIX "--> "
@@ -63,329 +64,591 @@
namespace eval portimage {
+variable force 0
+variable use_reg2 0
+
# Activate a "Port Image"
-proc activate {name specifier optionslist} {
+proc activate {name v optionslist} {
global macports::prefix macports::registry.path UI_PREFIX
array set options $optionslist
+ variable force
+ variable use_reg2
- if {[info exists options(ports_force)] && [string is true $options(ports_force)] } {
+ if {[info exists options(ports_force)] && [string is true -strict $options(ports_force)] } {
set force 1
- } else {
- set force 0
}
+ set use_reg2 [string equal ${macports::registry.format} "receipt_sqlite"]
+ set todeactivate [list]
- if {$specifier != ""} {
- ui_msg "$UI_PREFIX [format [msgcat::mc "Activating %s @%s"] $name $specifier]"
- } else {
- ui_msg "$UI_PREFIX [format [msgcat::mc "Activating %s"] $name]"
- }
+ if {$use_reg2} {
+ registry::read {
- registry::read {
+ set requested [_check_registry $name $v]
+ # set name again since the one we were passed may not have had the correct case
+ set name [$requested name]
+ set version [$requested version]
+ set revision [$requested revision]
+ set variants [$requested variants]
+ set specifier "${version}_${revision}${variants}"
- set requested [_check_registry $name $specifier]
- set version [$requested version]
- set revision [$requested revision]
- set variants [$requested variants]
- set specifier "${version}_$revision$variants"
+ # if another version of this port is active, deactivate it first
+ set current [registry::entry installed $name]
+ if { [llength $current] > 1 } {
+ foreach i $current {
+ set iversion [$i version]
+ set irevision [$i revision]
+ set ivariants [$i variants]
+ set ispecifier "${iversion}_${irevision}${ivariants}"
+ if { ![string equal $specifier $ispecifier]
+ && [string equal [$i state] "installed"] } {
+ lappend todeactivate $ispecifier
+ }
+ }
+ }
- set current [registry::entry installed $name]
- if { [llength $current] > 1 } {
- foreach i $current {
- set iname [$i name]
- set iversion [$i version]
- set irevision [$i revision]
- set ivariants [$i variants]
- set ispecifier "${iversion}_$irevision$ivariants"
- if { ![string equal $specifier $ispecifier]
- && [string equal [$i state] "installed"] } {
- return -code error "Image error: Another version of this port ($iname @${iversion}_${irevision}${ivariants}) is already active."
+ # this shouldn't be possible
+ if { ![string equal [$requested installtype] "image"] } {
+ return -code error "Image error: ${name} @${version}_${revision}${variants} not installed as an image."
+ }
+
+ if { [string equal [$requested state] "active"] } {
+ return -code error "Image error: ${name} @${version}_${revision}${variants} is already active."
+ }
+ }
+ } else {
+ # registry1.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]
+
+ # if another version of this port is active, deactivate it first
+ set ilist [registry::installed $name]
+ if { [llength $ilist] > 1 } {
+ foreach i $ilist {
+ 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 } {
+ lappend todeactivate "${iversion}_${irevision}${ivariants}"
}
}
}
- # this shouldn't be possible
- if { ![string equal [$requested installtype] "image"] } {
+ set ref [registry::open_entry $name $version $revision $variants]
+
+ if { ![string equal [registry::property_retrieve $ref installtype] "image"] } {
return -code error "Image error: ${name} @${version}_${revision}${variants} not installed as an image."
}
-
- if { [string equal [$requested state] "active"] } {
+ if { [registry::property_retrieve $ref active] != 0 } {
return -code error "Image error: ${name} @${version}_${revision}${variants} is already active."
}
}
- _activate_contents $port $force
- $requested state active
+ foreach a $todeactivate {
+ deactivate $name $a [list ports_force 1]
+ }
+
+ 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]"
+ }
+
+ if {$use_reg2} {
+ _activate_contents $port
+ $requested state active
+ } else {
+ set imagedir [registry::property_retrieve $ref imagedir]
+
+ set contents [registry::property_retrieve $ref contents]
+
+ set imagefiles [_check_contents $name $contents $imagedir]
+
+ registry::open_file_map
+ _activate_contents $name $imagefiles $imagedir
+
+ registry::property_store $ref active 1
+
+ registry::write_entry $ref
+
+ foreach file $imagefiles {
+ registry::register_file $file $name
+ }
+ registry::write_file_map
+ registry::close_file_map
+ }
}
-proc deactivate {name spec optionslist} {
+proc deactivate {name v optionslist} {
global UI_PREFIX
array set options $optionslist
+ variable use_reg2
- if {[info exists options(ports_force)] && [string is true $options(ports_force)] } {
+ if {[info exists options(ports_force)] && [string is true -strict $options(ports_force)] } {
+ # this not using the namespace variable is correct, since activate
+ # needs to be able to force deactivate independently of whether
+ # the activation is being forced
set force 1
- } else {
- set force 0
}
+ set use_reg2 [string equal ${macports::registry.format} "receipt_sqlite"]
- if {$spec != ""} {
- ui_msg "$UI_PREFIX [format [msgcat::mc "Deactivating %s @%s"] $name $spec]"
+ if {$use_reg2} {
+ if { [string equal $name ""] } {
+ throw registry::image-error "Registry error: Please specify the name of the port."
+ }
+ set ilist [registry::entry installed $name]
+ if { [llength $ilist] == 1 } {
+ set requested [lindex $ilist 0]
+ } else {
+ throw registry::image-error "Image error: port ${name} is not active."
+ }
+ # set name again since the one we were passed may not have had the correct case
+ set name [$requested name]
+ set version [$requested version]
+ set revision [$requested revision]
+ set variants [$requested variants]
+ set specifier "${version}_${revision}${variants}"
} else {
- ui_msg "$UI_PREFIX [format [msgcat::mc "Deactivating %s"] $name]"
+ 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 specifier "${version}_${revision}${variants}"
}
- if { [string equal $name {}] } {
- throw registry::image-error "Registry error: Please specify the name of the port."
+ if { $v != "" && ![string equal $specifier $v] } {
+ return -code error "Active version of $name is not $v but ${specifier}."
}
- set ilist [registry::entry installed $name]
- if { [llength $ilist] == 1 } {
- set requested [lindex $ilist 0]
+
+ if {$v != ""} {
+ ui_msg "$UI_PREFIX [format [msgcat::mc "Deactivating %s @%s"] $name $v]"
} else {
- throw registry::image-error "Image error: port ${name} is not active."
+ ui_msg "$UI_PREFIX [format [msgcat::mc "Deactivating %s"] $name]"
}
- set version [$requested version]
- set revision [$requested revision]
- set variants [$requested variants]
- set specifier ${version}_$revision$variants
- if { ![string equal $spec {}] && ![string equal $spec $specifier] } {
- return -code error "Active version of $name is not $spec but $specifier."
- }
- if { ![string equal [$requested installtype] "image"] } {
- return -code error "Image error: ${name} @${specifier} not installed as an image."
- }
- # this shouldn't be possible
- if { [$requested state] != "installed" } {
- return -code error "Image error: ${name} @${specifier} is not active."
- }
+ if {$use_reg2} {
+ if { ![string equal [$requested installtype] "image"] } {
+ return -code error "Image error: ${name} @${specifier} not installed as an image."
+ }
+ # this shouldn't be possible
+ if { [$requested state] != "installed" } {
+ return -code error "Image error: ${name} @${specifier} is not active."
+ }
- registry::check_dependents $port $force
+ registry::check_dependents $port $force
- set imagedir [$requested imagedir]
- set imagefiles [$requested files]
+ _deactivate_contents $requested {} $force
+ $requested state imaged
+ } else {
+ set ref [registry::open_entry $name $version $revision $variants]
- _deactivate_contents $requested $force
- $requested state imaged
+ if { ![string equal [registry::property_retrieve $ref installtype] "image"] } {
+ return -code error "Image error: ${name} @${specifier} not installed as an image."
+ }
+ if { [registry::property_retrieve $ref active] != 1 } {
+ return -code error "Image error: ${name} @${specifier} is not active."
+ }
+
+ registry::open_file_map
+ set imagefiles [registry::port_registered $name]
+
+ _deactivate_contents $name $imagefiles
+
+ 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 specifier} {
+proc _check_registry {name v} {
global UI_PREFIX
+ variable use_reg2
- if { [registry::decode_spec $specifier version revision variants] } {
- set ilist [registry::entry imaged $name $version $revision $variants]
- set valid 1
- } else {
- set valid [string equal $specifier {}]
- set ilist [registry::entry imaged $name]
- }
+ if {$use_reg2} {
+ if { [registry::decode_spec $v version revision variants] } {
+ set ilist [registry::entry imaged $name $version $revision $variants]
+ set valid 1
+ } else {
+ set valid [string equal $v {}]
+ set ilist [registry::entry imaged $name]
+ }
- if { [llength $ilist] > 1 || (!$valid && [llength $ilist] == 1) } {
- ui_msg "$UI_PREFIX [msgcat::mc "The following versions of $name are currently installed:"]"
- foreach i $ilist {
- set iname [$i name]
- set iversion [$i version]
- set irevision [$i revision]
- set ivariants [$i variants]
- if { [$i state] == "installed" } {
- ui_msg "$UI_PREFIX [format [msgcat::mc " %s @%s_%s%s (active)"] $iname $iversion $irevision $ivariants]"
+ if { [llength $ilist] > 1 || (!$valid && [llength $ilist] == 1) } {
+ ui_msg "$UI_PREFIX [msgcat::mc "The following versions of $name are currently installed:"]"
+ foreach i $ilist {
+ set iname [$i name]
+ set iversion [$i version]
+ set irevision [$i revision]
+ set ivariants [$i variants]
+ if { [$i state] == "installed" } {
+ ui_msg "$UI_PREFIX [format [msgcat::mc " %s @%s_%s%s (active)"] $iname $iversion $irevision $ivariants]"
+ } else {
+ ui_msg "$UI_PREFIX [format [msgcat::mc " %s @%s_%s%s"] $iname $iversion $irevision $ivariants]"
+ }
+ }
+ if { $valid } {
+ throw registry::invalid "Registry error: Please specify the full version as recorded in the port registry."
} else {
- ui_msg "$UI_PREFIX [format [msgcat::mc " %s @%s_%s%s"] $iname $iversion $irevision $ivariants]"
+ throw registry::invalid "Registry error: Invalid version specified. Please specify a version as recorded in the port registry."
}
+ } elseif { [llength $ilist] == 1 } {
+ return [lindex $ilist 0]
}
- if { $valid } {
- throw registry::invalid "Registry error: Please specify the full version as recorded in the port registry."
- } else {
- throw registry::invalid "Registry error: Invalid version specified. Please specify a version as recorded in the port registry."
+ throw registry::invalid "Registry error: No port of $name installed."
+ } else {
+ # registry1.0
+ set ilist [registry::installed $name $v]
+ if { [string equal $v ""] && [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."
+ } elseif {[llength $ilist] == 1} {
+ return [lindex $ilist 0]
}
- } else if { [llength $ilist] == 1 } {
- return [lindex $ilist 0]
+ return -code error "Registry error: No port of $name installed."
}
- throw registry::invalid "Registry error: No port of $name installed."
}
+proc _check_contents {name contents imagedir} {
+
+ set imagefiles [list]
+ set idlen [string length $imagedir]
+
+ # generate list of activated file paths from list of paths in the image dir
+ foreach fe $contents {
+ set srcfile [lindex $fe 0]
+ if { ![string equal $srcfile ""] && [file type $srcfile] != "directory" } {
+ set file [string range $srcfile $idlen [string length $srcfile]]
+
+ lappend imagefiles $file
+ }
+ }
+
+ return $imagefiles
+}
+
## Activates a file from an image into the filesystem. Deals with symlinks,
## directories and files.
##
## @param [in] srcfile path to file in image
## @param [in] dstfile path to activate file to
proc _activate_file {srcfile dstfile} {
- switch { [file type $srcfile] } {
- case link {
+ switch [file type $srcfile] {
+ link {
ui_debug "activating link: $dstfile"
- file copy -force $srcfile $dstfile
+ file copy -force -- $srcfile $dstfile
}
- case directory {
+ directory {
# Don't recursively copy directories
ui_debug "activating directory: $dstfile"
# Don't do anything if the directory already exists.
if { ![file isdirectory $dstfile] } {
file mkdir $dstfile
- # copy attributes, set mtime and atime
- eval file attributes [list $dstfile] [file attributes $srcfile]
+ # fix attributes on the directory.
+ eval file attributes {$dstfile} [file attributes $srcfile]
+ # set mtime on installed element
file mtime $dstfile [file mtime $srcfile]
- file atime $dstfile [file atime $srcfile]
}
}
- case file {
+ default {
ui_debug "activating file: $dstfile"
# Try a hard link first and if that fails, a symlink
- try {
- file link -hard $dstfile $srcfile
- } catch {*} {
- ui_debug "hardlinking $srcfile to $dstfile failed; symlinking instead"
+ if {[catch {file link -hard $dstfile $srcfile}]} {
+ ui_debug "hardlinking $srcfile to $dstfile failed, symlinking instead"
file link -symbolic $dstfile $srcfile
}
}
- default {
- # don't activate e.g. a unix socket
- ui_warning "skipped file $srcfile of unknown type [file type $srcfile]"
- }
}
}
## Activates the contents of a port
-proc _activate_contents {port force} {
+proc _activate_contents {port {imagefiles {}} {imagedir {}}} {
+ variable force
+ variable use_reg2
global macports::prefix
set files [list]
- set imagedir [$port imagedir]
- set imagefiles [$port imagefiles]
-
- # first, ensure all files exist in the image dir
- foreach file $imagefiles {
- set srcfile $imagedir$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)
- try {
- file lstat $srcfile dummystatvar
- } catch {*} {
- throw registry::image-error "Image error: Source file $srcfile does not appear to exist (cannot lstat it). Unable to activate port [$port name]."
- }
+ set baksuffix .mp_[clock seconds]
+ if {$use_reg2} {
+ set imagedir [$port imagedir]
+ set imagefiles [$port imagefiles]
+ } else {
+ set name $port
}
- set baksuffix .mp_[clock seconds]
+ set deactivated [list]
set backups [list]
-
# 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 $imagedir 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
- try {
- registry::write {
- foreach file $imagefiles {
- set srcfile ${imagedir}${file}
+ if {$use_reg2} {
+ try {
+ registry::write {
+ foreach file $imagefiles {
+ set srcfile "${imagedir}${file}"
- set owner [registry::entry owner $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}] } {
+ throw registry::image-error "Image error: Source file $srcfile does not appear to exist (cannot lstat it). Unable to activate port [$port name]."
+ }
- if { [string is true $force] } {
- # if we're forcing the activation, then we move any existing
- # files to a backup file, both in the filesystem and in the
- # registry
- if { [file exists $file] } {
- ui_warn "File $file already exists. Moving to: $bakfile."
- file rename -force $file $file$baksuffix
- lappend backups $file
+ set owner [registry::entry owner $file]
+
+ if {$owner != {} && $owner != $port} {
+ # deactivate conflicting port if it is replaced_by this one
+ set result [mportlookup [$owner name]]
+ array unset portinfo
+ array set portinfo [lindex $result 1]
+ if {[info exists portinfo(replaced_by)] && [lsearch -exact -nocase $portinfo(replaced_by) [$port name]] != -1} {
+ lappend deactivated $owner
+ deactivate [$owner name] "" ""
+ set owner {}
+ }
}
- if { $owner != {} } {
- $owner deactivate [list $file]
- $owner activate [list $file] [list $file$baksuffix]
+
+ if { [string is true -strict $force] } {
+ # if we're forcing the activation, then we move any existing
+ # files to a backup file, both in the filesystem and in the
+ # registry
+ if { [file exists $file] } {
+ set bakfile "${file}${baksuffix}"
+ ui_warn "File $file already exists. Moving to: $bakfile."
+ file rename -force -- $file $bakfile
+ lappend backups $file
+ }
+ if { $owner != {} } {
+ $owner deactivate [list $file]
+ $owner activate [list $file] [list "${file}${baksuffix}"]
+ }
+ } else {
+ # if we're not forcing the activation, then we bail out if
+ # we find any files that already exist, or have entries in
+ # the registry
+ if { $owner != {} && $owner != $port } {
+ 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."
+ } elseif { $owner == {} && [file exists $file] } {
+ 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."
+ }
}
- } else {
- # if we're not forcing the activation, then we bail out if
- # we find any files that already exist, or have entries in
- # the registry
- if { $owner != {} && $owner != $port } {
- throw registry::image-error "Image error: $file is being used by the active [$owner name] port. Please deactivate this port first, or use the -f flag to force the activation."
- } elseif { $owner == {} && [file exists $file] } {
- throw registry::image-error "Image error: $file already exists and does not belong to a registered port. Unable to activate port [$owner name]."
+
+ # 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
}
- # 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]
+ # 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
+ try {
+ [$port activate $imagefiles]
+ foreach file $theList {
+ _activate_file "${imagedir}${file}" $file
+ }
+ } catch {*} {
+ ui_debug "Activation failed, rolling back."
+ _deactivate_contents $port {} yes
+ throw
}
+ }
+ } catch {*} {
+ # if any errors occurred, move backed-up files back to their original
+ # locations, then rethrow the error. Transaction rollback will take care
+ # of this in the registry.
+ foreach file $backups {
+ file rename -force -- "${file}${baksuffix}" $file
+ }
+ # reactivate deactivated ports
+ foreach entry $deactivated {
+ set pvers "[$entry version]_[$entry revision][$entry variants]"
+ activate [$entry name] $pvers ""
+ }
+ throw
+ }
+ } else {
+ # registry1.0
+ foreach file $imagefiles {
+ set srcfile "${imagedir}${file}"
- # Also add the filename to the imagefile list.
- lappend files $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."
}
- # 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]
+ set port [registry::file_registered $file]
+
+ if {$port != 0 && $port != $name} {
+ # deactivate conflicting port if it is replaced_by this one
+ if {[catch {mportlookup $port} result]} {
+ global errorInfo
+ ui_debug "$errorInfo"
+ return -code error "port lookup failed: $result"
+ }
+ array unset portinfo
+ array set portinfo [lindex $result 1]
+ if {[info exists portinfo(replaced_by)] && [lsearch -exact -nocase $portinfo(replaced_by) $name] != -1} {
+ lappend deactivated [lindex [registry::active $port] 0]
+ deactivate $port "" ""
+ set port 0
+ }
+ }
+
+ if { $port != 0 && $force != 1 && $port != $name } {
+ 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. Use 'port -f activate $name' to force the activation."
+ } elseif { $force == 1 && [file exists $file] || $port != 0 } {
+ set bakfile "${file}${baksuffix}"
- # Activate it, and catch errors so we can roll-back
- try {
- [$port activate $imagefiles]
- foreach file $theList {
- _activate_file $imagedir$file $file
+ if {[file exists $file]} {
+ ui_warn "File $file already exists. Moving to: $bakfile."
+ file rename -force -- $file $bakfile
+ lappend backups $file
}
- } catch {*} {
- ui_debug "Activation failed, rolling back."
- _deactivate_contents $port yes
- throw
+
+ 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
}
- } catch {*} {
- # if any errors occurred, move backed-up files back to their original
- # locations, then rethrow the error. Transaction rollback will take care
- # of this in the registry.
- foreach file $backups {
- file rename -force $file$baksuffix $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 { foreach file $theList {
+ _activate_file "${imagedir}${file}" $file
+ }} result]} {
+ ui_debug "Activation failed, rolling back."
+ _deactivate_contents $name $imagefiles
+ # return backed up files to their old locations
+ foreach f $backups {
+ set bakfile "${f}${baksuffix}"
+ set bakport [registry::file_registered $bakfile]
+ if {$bakport != 0} {
+ registry::unregister_file $bakfile
+ registry::register_file $f $bakport
+ }
+ file rename -force -- $bakfile $file
+ }
+ # reactivate deactivated ports
+ foreach entry $deactivated {
+ set pname [lindex $entry 0]
+ set pvers "[lindex $entry 1]_[lindex $entry 2][lindex $entry 3]"
+ activate $pname $pvers ""
+ }
+ registry::write_file_map
+
+ return -code error $result
}
- throw
}
}
proc _deactivate_file {dstfile} {
- switch { [file type $dstfile] } {
- case link {
- ui_debug "deactivating link: $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"
}
- case directory {
- # 0 item means empty.
- if { [llength [readdir $dstfile]] == 0 } {
- ui_debug "deactivating directory: $dstfile"
- file delete -- $dstfile
- } else {
- ui_debug "$dstfile is not empty"
- }
- }
- case file {
- ui_debug "deactivating file: $dstfile"
- file delete -- $dstfile
- }
- default {
- # don't deactivate e.g. a unix socket
- ui_warning "skipped file $dstfile of unknown type [file type $dstfile]"
- }
+ } else {
+ ui_debug "deactivating file: $dstfile"
+ file delete -- $dstfile
}
}
-proc _deactivate_contents {port force} {
-
+proc _deactivate_contents {port imagefiles {force 0}} {
+ variable use_reg2
set files [list]
+ if {$use_reg2} {
+ set imagefiles [$port files]
+ }
- set realfiles [$port files]
-
- foreach file $realfiles {
- set owner [registry::entry owner $file]
+ 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)
@@ -398,10 +661,11 @@
set theFile [file normalize $file]
lappend files $theFile
- # Split out the filename's subpaths and add them to the image list
- # as well.
+ # 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 } {
+ while { [lsearch -exact $files $directory] == -1 } {
lappend files $directory
set directory [file dirname $directory]
}
@@ -415,9 +679,15 @@
# are after their elements.
set theList [lsort -decreasing -unique $files]
- registry::write {
- # Remove all elements.
- $port deactivate $realfiles
+ # Remove all elements.
+ if {$use_reg2} {
+ registry::write {
+ $port deactivate $imagefiles
+ foreach file $theList {
+ _deactivate_file $file
+ }
+ }
+ } else {
foreach file $theList {
_deactivate_file $file
}
Modified: trunk/base/src/registry2.0/portuninstall.tcl
===================================================================
--- trunk/base/src/registry2.0/portuninstall.tcl 2010-02-04 00:37:32 UTC (rev 63397)
+++ trunk/base/src/registry2.0/portuninstall.tcl 2010-02-04 00:46:00 UTC (rev 63398)
@@ -1,4 +1,4 @@
-# et:ts=4
+# -*- 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
# portuninstall.tcl
# $Id$
#
@@ -16,7 +16,7 @@
# 3. Neither the name of Apple 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
@@ -32,6 +32,7 @@
package provide portuninstall 2.0
+package require registry 1.0
package require registry2 2.0
package require registry_util 2.0
@@ -39,100 +40,248 @@
namespace eval portuninstall {
-proc uninstall {portname {specifier ""} optionslist} {
- global uninstall.force uninstall.nochecksum UI_PREFIX
- array set options $optionslist
+proc uninstall {portname {v ""} optionslist} {
+ global uninstall.force uninstall.nochecksum UI_PREFIX macports::registry.format
+ array set options $optionslist
- if {[info exists options(ports_force)] && [string is true $options(ports_force)] } {
- set force 1
- } else {
- set force 0
+ if {![info exists uninstall.force]} {
+ set uninstall.force no
}
+ # If global forcing is on, make it the same as a local force flag.
+ if {[info exists options(ports_force)] && [string is true -strict $options(ports_force)]} {
+ set uninstall.force yes
+ }
+ # check which registry API to use
+ set use_reg2 [string equal ${macports::registry.format} "receipt_sqlite"]
- if { [registry::decode_spec $specifier version revision variants] } {
- set ilist [registry::entry imaged $portname $version $revision $variants]
+ if {$use_reg2} {
+ if { [registry::decode_spec $v version revision variants] } {
+ set ilist [registry::entry imaged $portname $version $revision $variants]
+ set valid 1
+ } else {
+ set valid [string equal $v {}]
+ set ilist [registry::entry imaged $portname]
+ }
+ } else {
+ set ilist [registry::installed $portname $v]
set valid 1
- } else {
- set valid [string equal $specifier {}]
- set ilist [registry::entry imaged $portname]
}
-
- if { [llength $ilist] > 1 } {
- ui_msg "$UI_PREFIX [format [msgcat::mc "The following versions of %s are currently installed:"] $portname]"
- foreach i $ilist {
- set iname [lindex $i 0]
- set iactive [lindex $i 4]
- set ispec "[$i version]_[$i revision][$i variants]"
- if { [string equal [$i state] installed] } {
- ui_msg "$UI_PREFIX [format [msgcat::mc " %s @%s (active)"] $iname $ispec]"
- } elseif { $iactive == 1 } {
- ui_msg "$UI_PREFIX [format [msgcat::mc " %s @%s"] $iname $ispec]"
- }
- }
+ if { [llength $ilist] > 1 } {
+ set portname [lindex [lindex $ilist 0] 0]
+ ui_msg "$UI_PREFIX [msgcat::mc "The following versions of $portname are currently installed:"]"
+ foreach i [portlist_sortint $ilist] {
+ set iname [lindex $i 0]
+ set iactive [lindex $i 4]
+ if {$use_reg2} {
+ set ispec "[$i version]_[$i revision][$i variants]"
+ if { [string equal [$i state] installed] } {
+ ui_msg "$UI_PREFIX [format [msgcat::mc " %s @%s (active)"] $iname $ispec]"
+ } elseif { $iactive == 1 } {
+ ui_msg "$UI_PREFIX [format [msgcat::mc " %s @%s"] $iname $ispec]"
+ }
+ } else {
+ set iversion [lindex $i 1]
+ set irevision [lindex $i 2]
+ set ivariants [lindex $i 3]
+ 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]"
+ }
+ }
+ }
if { $valid } {
throw registry::invalid "Registry error: Please specify the full version as recorded in the port registry."
} else {
throw registry::invalid "Registry error: Invalid version specified. Please specify a version as recorded in the port registry."
}
- } elseif { [llength $ilist] == 1 } {
- set port [lindex $ilist 0]
- } else {
+ } elseif { [llength $ilist] == 1 } {
+ # set portname again since the one we were passed may not have had the correct case
+ set portname [lindex [lindex $ilist 0] 0]
+ if {$use_reg2} {
+ set port [lindex $ilist 0]
+ if {$v == ""} {
+ set v "[$port version]_[$port revision][$port variants]"
+ }
+ } else {
+ set version [lindex [lindex $ilist 0] 1]
+ set revision [lindex [lindex $ilist 0] 2]
+ set variants [lindex [lindex $ilist 0] 3]
+ set active [lindex [lindex $ilist 0] 4]
+ if {$v == ""} {
+ set v "${version}_${revision}${variants}"
+ }
+ }
+ } else {
throw registry::invalid "Registry error: $portname not registered as installed"
}
- if { [string equal [$port installtype] direct] } {
- # if port is installed directly, check its dependents
- registry::check_dependents $port $force
- } else {
- # if it's an image, deactivate it (and check dependents there)
+ if {$use_reg2} {
+ # uninstall dependents if requested
+ if {[info exists options(ports_uninstall_follow-dependents)] && $options(ports_uninstall_follow-dependents) eq "yes"} {
+ foreach depport [$port dependents] {
+ # make sure it's still installed, since a previous dep uninstall may have removed it
+ if {[$depport state] == "imaged" || [$depport state] == "installed"} {
+ set depname [$depport name]
+ set depver "[$depport version]_[$depport revision][$depport variants]"
+ portuninstall::uninstall $depname $depver [array get options]
+ }
+ }
+ } else {
+ # check its dependents
+ registry::check_dependents $port ${uninstall.force}
+ }
+ # if it's an image, deactivate it
if { [string equal [$port state] installed] } {
- portimage::deactivate $portname ${version}_${revision}${variants} $optionslist
+ if {[info exists options(ports_dryrun)] && [string is true -strict $options(ports_dryrun)]} {
+ ui_msg "For $portname @${v}: skipping deactivate (dry run)"
+ } else {
+ portimage::deactivate $portname $v $optionslist
+ }
}
- }
+ } else {
+ # registry1.0
+
+ # determine if it's the only installed port with that name or not.
+ if {$v == ""} {
+ set nb_versions_installed 1
+ } else {
+ set ilist [registry::installed $portname ""]
+ set nb_versions_installed [llength $ilist]
+ }
+
+ set ref [registry::open_entry $portname $version $revision $variants]
+
+ # Check and make sure no ports depend on this one
+ registry::open_dep_map
+ set deplist [registry::list_dependents $portname]
+ if { [llength $deplist] > 0 } {
+ set dl [list]
+ # Check the deps first
+ foreach dep $deplist {
+ set depport [lindex $dep 2]
+ ui_debug "$depport depends on this port"
+ if {[registry::entry_exists_for_name $depport]} {
+ lappend dl $depport
+ }
+ }
+ # Now see if we need to error
+ if { [llength $dl] > 0 } {
+ if {[info exists options(ports_uninstall_follow-dependents)] && $options(ports_uninstall_follow-dependents) eq "yes"} {
+ foreach depport $dl {
+ # make sure it's still installed, since a previous dep uninstall may have removed it
+ if {[registry::entry_exists_for_name $depport]} {
+ portuninstall::uninstall $depport "" [array get options]
+ }
+ }
+ } else {
+ # will need to change this when we get version/variant dependencies
+ if {$nb_versions_installed == 1 || $active == 1} {
+ ui_msg "$UI_PREFIX [format [msgcat::mc "Unable to uninstall %s %s_%s%s, the following ports depend on it:"] $portname $version $revision $variants]"
+ foreach depport $dl {
+ ui_msg "$UI_PREFIX [format [msgcat::mc " %s"] $depport]"
+ }
+ if { [string is true -strict ${uninstall.force}] } {
+ ui_warn "Uninstall forced. Proceeding despite dependencies."
+ } else {
+ return -code error "Please uninstall the ports that depend on $portname first."
+ }
+ }
+ }
+ }
+ }
+
+ set installtype [registry::property_retrieve $ref installtype]
+ if { $installtype == "image" && [registry::property_retrieve $ref active] == 1} {
+ if {[info exists options(ports_dryrun)] && [string is true -strict $options(ports_dryrun)]} {
+ ui_msg "For $portname @${version}_${revision}${variants}: skipping deactivate (dry run)"
+ } else {
+ portimage::deactivate $portname ${version}_${revision}${variants} $optionslist
+ }
+ }
+ }
- ui_msg "$UI_PREFIX [format [msgcat::mc "Uninstalling %s @%s_%s%s"] $portname $version $revision $variants]"
+ if {[info exists options(ports_dryrun)] && [string is true -strict $options(ports_dryrun)]} {
+ ui_msg "For $portname @${v}: skipping uninstall (dry run)"
+ return 0
+ }
- # pkg_uninstall isn't used anywhere as far as I can tell and I intend to add
- # some proper pre-/post- hooks to uninstall/deactivate.
+ ui_msg "$UI_PREFIX [format [msgcat::mc "Uninstalling %s @%s"] $portname $v]"
- # Look to see if the port has registered an uninstall procedure
- #set uninstall [registry::property_retrieve $ref pkg_uninstall]
- #if { $uninstall != 0 } {
- # if {![catch {eval $uninstall} err]} {
- # pkg_uninstall $portname ${version}_${revision}${variants}
- # } else {
- # global errorInfo
- # ui_debug "$errorInfo"
- # ui_error [format [msgcat::mc "Could not evaluate pkg_uninstall procedure: %s"] $err]
- # }
- #}
+ if {$use_reg2} {
+ # pkg_uninstall isn't used anywhere as far as I can tell and I intend to add
+ # some proper pre-/post- hooks to uninstall/deactivate.
+ } else {
+ # Look to see if the port has registered an uninstall procedure
+ set uninstall [registry::property_retrieve $ref pkg_uninstall]
+ if { $uninstall != 0 } {
+ if {![catch {eval $uninstall} err]} {
+ pkg_uninstall $portname $v
+ } else {
+ global errorInfo
+ ui_debug "$errorInfo"
+ ui_error [format [msgcat::mc "Could not evaluate pkg_uninstall procedure: %s"] $err]
+ }
+ }
+
+ # Remove the port from the dep_map if only one version was installed.
+ # This is a temporary fix for a deeper problem that is that the dependency
+ # map doesn't take the port version into account (but should).
+ # Fixing it means transitionning to a new dependency map format.
+ if {$nb_versions_installed == 1} {
+ registry::unregister_dependencies $portname
+ }
+ }
- set contents [$port files]
-
- set bak_suffix .mp_[time seconds]
- set uninst_err 0
+ # Now look for a contents list
+ if {$use_reg2} {
+ set contents [$port files]
+ } else {
+ set contents [registry::property_retrieve $ref contents]
+ if { $contents == "" } {
+ return -code error [msgcat::mc "Uninstall failed: Port has no contents entry"]
+ }
+ }
+ set bak_suffix ".mp_[clock seconds]"
set files [list]
- foreach file $contents {
- if { !([info exists uninstall.nochecksum]
- && [string is true $uninstall.nochecksum]) } {
- set sum1 [$port md5sum $file]
- if {![catch {set sum2 [md5 $file]}] && ![string match $sum1 $sum2]} {
- ui_info "$UI_PREFIX [format [msgcat::mc "Original checksum does not match for %s, saving a copy to %s"] $file $file$bak_suffix]"
- file copy $file $file$bak_suffix
+ foreach f $contents {
+ if {$use_reg2} {
+ set fname $f
+ set sum1 [$port md5sum $f]
+ } else {
+ set fname [lindex $f 0]
+ set md5index [lsearch -regex [lrange $f 1 end] MD5]
+ if {$md5index != -1} {
+ set sumx [lindex $f [expr $md5index + 1]]
+ } else {
+ # XXX There is no MD5 listed, set sumx to an
+ # empty list, causing the next conditional to
+ # return a checksum error
+ set sumx {}
}
+ set sum1 [lindex $sumx [expr [llength $sumx] - 1]]
}
+ if {![string match $sum1 NONE] && !([info exists uninstall.nochecksum] && [string is true -strict ${uninstall.nochecksum}]) } {
+ if {![catch {set sum2 [md5 $fname]}] && ![string match $sum1 $sum2]} {
+ ui_warn "$UI_PREFIX [format [msgcat::mc "Original checksum does not match for %s, saving a copy to %s"] $file ${file}${bak_suffix}]"
+ catch {file copy $file "${file}${bak_suffix}"}
+ }
+ }
+
+ set theFile [file normalize $fname]
+ if { [file exists $theFile] || (![catch {file type $theFile}] && [file type $theFile] == "link") } {
+ # Normalize the file path to avoid removing the intermediate
+ # symlinks (remove the empty directories instead)
+ lappend files $theFile
- # Normalize the file path to avoid removing the intermediate
- # symlinks (remove the empty directories instead)
- set theFile [file normalize $file]
- lappend files $theFile
-
- # Split out the filename's subpaths and add them to the
- # list as well.
- set directory [realpath [file dirname $theFile]]
- while { [lsearch -exact $files $directory] == -1 } {
- lappend files $directory
- set directory [file dirname $directory]
+ # Split out the filename's subpaths and add them to the
+ # 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]
+ }
}
}
@@ -142,48 +291,43 @@
set theList [lsort -decreasing -unique $files]
# Remove all elements.
- foreach file $theList {
- _uninstall_file $file
+ _uninstall_list $theList
+
+ if {$use_reg2} {
+ registry::entry delete $port
+ } else {
+ ui_info "$UI_PREFIX [format [msgcat::mc "Uninstall is removing %s from the port registry."] $portname]"
+ registry::delete_entry $ref
}
-
- ui_info "$UI_PREFIX [format [msgcat::mc "Uninstall is removing %s from the port registry."] $portname]"
- registry::entry delete $port
return 0
}
proc _uninstall_file {dstfile} {
- if { ![catch {set type [file type $dstfile]}] } {
- switch {$type} {
- case link {
- ui_debug "uninstalling link: $dstfile"
+ if { ![catch {set type [file type $dstfile]}] } {
+ if { $type == "link" } {
+ ui_debug "uninstalling link: $dstfile"
+ file delete -- $dstfile
+ } elseif { [file isdirectory $dstfile] } {
+ # 0 item means empty.
+ if { [llength [readdir $dstfile]] == 0 } {
+ ui_debug "uninstalling directory: $dstfile"
file delete -- $dstfile
+ } else {
+ ui_debug "$dstfile is not empty"
}
- case directory {
- # 0 item means empty.
- if { [llength [readdir $dstfile]] == 0 } {
- ui_debug "uninstalling directory: $dstfile"
- file delete -- $dstfile
- } else {
- ui_debug "$dstfile is not empty"
- }
- }
- case file {
- ui_debug "uninstalling file: $dstfile"
- file delete -- $dstfile
- }
- default {
- ui_debug "skip file of unknown type $type: $dstfile"
- }
+ } else {
+ ui_debug "uninstalling file: $dstfile"
+ file delete -- $dstfile
}
- } else {
- ui_debug "skip missing file: $dstfile"
- }
+ } else {
+ ui_debug "skip missing file: $dstfile"
+ }
}
proc _uninstall_list {filelist} {
- foreach file $filelist {
- _uninstall_file $file
- }
+ foreach file $filelist {
+ _uninstall_file $file
+ }
}
# End of portuninstall namespace
Copied: trunk/base/src/registry2.0/receipt_flat.tcl (from rev 63371, trunk/base/src/registry1.0/receipt_flat.tcl)
===================================================================
--- trunk/base/src/registry2.0/receipt_flat.tcl (rev 0)
+++ trunk/base/src/registry2.0/receipt_flat.tcl 2010-02-04 00:46:00 UTC (rev 63398)
@@ -0,0 +1,864 @@
+# receipt_flat.tcl
+# $Id$
+#
+# Copyright (c) 2004 Will Barton <wbb4 at opendarwin.org>
+# Copyright (c) 2004 Paul Guyot, The MacPorts Project.
+# 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 receipt_flat 1.0
+
+package require macports 1.0
+package require Pextlib 1.0
+
+##
+# Receipts Code supporting flat-files
+##
+namespace eval receipt_flat {
+
+# receipt_lastref is the last attributed index of receipts.
+variable receipt_lastref -1
+# maps port name,version,variants to the corresponding receipt ref
+variable ref_index
+
+##
+#
+# Create a new entry and return its reference number.
+# The reference number allows us to retrieve the receipt array.
+proc new_entry {} {
+ variable receipt_lastref
+ incr receipt_lastref
+
+ variable receipt_$receipt_lastref
+ array set receipt_$receipt_lastref {}
+
+ return $receipt_lastref
+}
+
+##
+#
+# Get the path to the receipt in HEAD format.
+# Remark: this code doesn't work for some ports.
+# That's why we moved to the new path format in the first place.
+#
+# portname the name of the port.
+# portversion the version for this port, 0 if unknown.
+# return the path to the file or "" if the file couldn't be found.
+proc get_head_entry_receipt_path {portname portversion} {
+ global macports::registry.path
+
+ # regex match case
+ if {$portversion == 0} {
+ set x [glob -nocomplain -directory [file join ${macports::registry.path} receipts] -- ${portname}-*]
+ if {[string length $x]} {
+ set matchfile [lindex $x 0]
+ # Remove trailing .bz2, if any.
+ regexp {(.*)\.bz2$} $matchfile match matchfile
+ } else {
+ set matchfile ""
+ }
+ } else {
+ set matchfile [file join ${macports::registry.path} receipts ${portname}-${portversion}]
+ }
+
+ # Might as well bail out early if no file to match
+ if {![string length $matchfile]} {
+ return ""
+ }
+
+ if {[file exists $matchfile] || [file exists ${matchfile}.bz2]} {
+ return $matchfile
+ }
+ return ""
+}
+
+##
+#
+# Open an existing entry and return its reference number.
+proc open_entry {name {version ""} {revision 0} {variants ""}} {
+ global macports::registry.installtype
+ global macports::registry.path
+ variable ref_index
+
+ # if this entry is already open, just return the reference
+ if {[info exists ref_index($name,$version,$revision,$variants)]} {
+ return $ref_index($name,$version,$revision,$variants)
+ }
+
+ set receipt_path [file join ${macports::registry.path} receipts ${name}]
+
+ # If the receipt path ${name} doesn't exist, then the receipt probably is
+ # in the old HEAD format.
+ if { ![file isdirectory $receipt_path] } {
+ set receipt_file [get_head_entry_receipt_path $name $version]
+
+ if {![string length $receipt_file]} {
+ if { $version != "" } {
+ return -code error "Registry error: ${name} @${version}_${revision}${variants} not registered as installed."
+ } else {
+ return -code error "Registry error: ${name} not registered as installed."
+ }
+ }
+
+ # Extract the version from the path.
+ if { $version == "" } {
+ set theFileName [file tail $receipt_file]
+ regexp "^$name-(.*)\$" $theFileName match version
+ }
+ } else {
+ # If version wasn't specified, find out the version number. This will
+ # depend on which installtype mode we're in, "direct" or "image"
+ if { $version == "" } {
+ # xxx: If we're in image mode, we really should have had the
+ # version given to us. How should we handle this?
+ set x [glob -nocomplain -directory ${receipt_path} *]
+ if { [string length $x] } {
+ set v [lindex [file split [lindex $x 0]] end]
+ regexp {([-_a-zA-Z0-9\.]+)_([0-9]*)([+-_a-zA-Z0-9]*)$} $v match version revision variants
+ } else {
+ return -code error "Registry error: ${name} not registered as installed."
+ }
+ }
+
+ if { ![entry_exists $name $version $revision $variants] } {
+ return -code error "Registry error: ${name} @${version}_${revision}${variants} not registered as installed."
+ }
+
+ set receipt_path [file join ${macports::registry.path} receipts ${name} ${version}_${revision}${variants}]
+
+ set receipt_file [file join ${receipt_path} receipt]
+ }
+
+ if { [file exists ${receipt_file}.bz2] && [file exists ${registry::autoconf::bzip2_path}] } {
+ set receipt_file ${receipt_file}.bz2
+ set receipt_contents [exec ${registry::autoconf::bzip2_path} -d -c ${receipt_file}]
+ } elseif { [file exists ${receipt_file}] } {
+ set receipt_handle [open ${receipt_file} r]
+ set receipt_contents [read $receipt_handle]
+ close $receipt_handle
+ } else {
+ return -code error "Registry error: receipt for ${name} @${version}_${revision}${variants} seems to be compressed, but bzip2 couldn't be found."
+ }
+
+ set ref [new_entry]
+ variable receipt_$ref
+
+ # Determine the format of the receipt.
+ if {[string match "# Format: var value ...*" $receipt_contents]} {
+ # This is old HEAD format.
+ # We convert it and we save it.
+ # tell the user
+ ui_msg "Converting receipt for $name-$version to new format"
+
+ convert_entry_from_HEAD $name $version $revision $variants $receipt_contents $ref
+
+ # move the old receipt
+ set convertedDirPath [file join ${macports::registry.path} receipts_converted]
+ file mkdir $convertedDirPath
+ file rename -- $receipt_file $convertedDirPath
+ } elseif {[string match "# Version: *" $receipt_contents]} {
+ # This is new format
+ if {![string match "# Version: 1.0*" $receipt_contents]} {
+ return -code error "Registry error: receipt ${name} @${version}_${revision}${variants} is in an unknown format (version too new?)."
+ }
+
+ # Remove any line starting with #
+ while {[regexp "(^|\n)#.*\n(.*)\$" $receipt_contents match foo receipt_contents]} {}
+ if {[catch {array set receipt_$ref $receipt_contents} rcpterr]} {
+ ui_error "Malformed receipt for ${name} @${version}_${revision}${variants}"
+ ui_error "receipt_contents = '$receipt_contents'"
+ error $rcpterr
+ }
+ } else {
+ # This is old Images format
+
+ # Iterate on the elements of $receipt_contents and add them to the list.
+ foreach pair $receipt_contents {
+ array set receipt_[set ref] $pair
+ }
+ }
+
+ set ref_index($name,$version,$revision,$variants) $ref
+
+ return $ref
+}
+
+##
+#
+# Convert an entry from HEAD old format.
+# HEAD old format is a file in the key,value format with key and values being on the
+# same line separated with a space.
+# This typically is read with an options-like approach.
+# This conversion routine also appends the contents to the file map.
+#
+# name the name of the port to convert.
+# version the version of the port to convert.
+# revision the revision of the port to convert (probably inaccurate).
+# variants the variants of the port to convert (idem).
+# receipt_contents the content of the old receipt file.
+# ref reference of the target receipt array where the content must be put.
+proc convert_entry_from_HEAD {name version revision variants receipt_contents ref} {
+ variable receipt_$ref
+
+ # First set default value for stuff that aren't in the receipt.
+ array set receipt_[set ref] [list name $name]
+ array set receipt_[set ref] [list version $version]
+ array set receipt_[set ref] [list revision $revision]
+ array set receipt_[set ref] [list variants $variants]
+ array set receipt_[set ref] [list installtype direct]
+ array set receipt_[set ref] [list receipt_f receipt_flat]
+ array set receipt_[set ref] [list active 1]
+
+ # Then start a new interpreter to read the content of the portfile.
+ interp create theConverterInterpreter
+ # Just ignore prefix.
+ interp eval theConverterInterpreter "proc prefix {args} {\n\
+ }"
+ # Also ignore run_depends.
+ interp eval theConverterInterpreter "proc run_depends {args} {\n\
+ }"
+ interp eval theConverterInterpreter "proc categories {args} {\n\
+ global theConvertedReceipt\n\
+ array set theConvertedReceipt \[list categories \$args\]\n\
+ }"
+ interp eval theConverterInterpreter "proc description {args} {\n\
+ global theConvertedReceipt\n\
+ array set theConvertedReceipt \[list description \$args\]\n\
+ }"
+ interp eval theConverterInterpreter "proc long_description {args} {\
+ global theConvertedReceipt\n\
+ array set theConvertedReceipt \[list long_description \$args\]\n\
+ }"
+ interp eval theConverterInterpreter "proc homepage {args} {\n\
+ global theConvertedReceipt\n\
+ array set theConvertedReceipt \[list homepage \$args\]\n\
+ }"
+ # contents already is a list.
+ interp eval theConverterInterpreter "proc contents {args} {\n\
+ variable contents\n\
+ set contents \[lindex \$args 0\]\n\
+ }"
+ interp eval theConverterInterpreter "array set theConvertedReceipt {}"
+ interp eval theConverterInterpreter "variable contents"
+ interp eval theConverterInterpreter $receipt_contents
+ array set receipt_$ref [interp eval theConverterInterpreter "array get theConvertedReceipt"]
+ set contents [interp eval theConverterInterpreter "set contents"]
+ interp delete theConverterInterpreter
+
+ # Append the contents list to the file map (only the files).
+ set theActualContents [list]
+ foreach file $contents {
+ if {[llength $file]} {
+ set theFilePath [lindex $file 0]
+ if {[file isfile $theFilePath]} {
+ set previousPort [file_registered $theFilePath]
+ if {$previousPort != 0} {
+ ui_warn "Conflict detected for file $theFilePath between $previousPort and $name."
+ }
+ if {[catch {register_file $theFilePath $name}]} {
+ ui_warn "An error occurred while adding $theFilePath to the file_map database."
+ }
+ } elseif {![file exists $theFilePath]} {
+ ui_warn "Port $name refers to $theFilePath which doesn't exist."
+ }
+ lappend theActualContents $file
+ } else {
+ ui_warn "Port $name contents list includes an empty element."
+ }
+ }
+
+ property_store $ref contents $theActualContents
+
+ # Save the file_map afterwards
+ write_file_map
+ close_file_map
+
+ # Save the entry to new format.
+ write_entry $ref $name $version $revision $variants
+}
+
+##
+#
+# Write the entry that was previously created.
+#
+# ref the reference number of the entry.
+# name the name of the port.
+# version the version of the port.
+# variants the variants of the port.
+proc write_entry {ref name version {revision 0} {variants ""}} {
+ global macports::registry.installtype
+ variable receipt_$ref
+
+ set receipt_contents [array get receipt_$ref]
+
+ set receipt_path [file join ${macports::registry.path} receipts ${name} ${version}_${revision}${variants}]
+ set receipt_file [file join ${receipt_path} receipt]
+
+ if { ![file isdirectory ${receipt_path}] } {
+ file mkdir ${receipt_path}
+ }
+
+ set receipt_handle [open ${receipt_file}.tmp w 0644]
+ puts $receipt_handle "# Version: 1.0"
+ puts $receipt_handle $receipt_contents
+ close $receipt_handle
+
+ if { [file exists ${receipt_file}] } {
+ file delete -force -- "${receipt_file}"
+ } elseif { [file exists ${receipt_file}.bz2] } {
+ file delete -force -- "${receipt_file}.bz2"
+ }
+
+ file rename -force -- "${receipt_file}.tmp" "${receipt_file}"
+
+ if { [file exists ${receipt_file}] && [file exists ${registry::autoconf::bzip2_path}] && ![info exists registry.nobzip] } {
+ system "${registry::autoconf::bzip2_path} -f ${receipt_file}"
+ }
+
+ return 1
+}
+
+# Check to see if an entry exists
+proc entry_exists {name version {revision 0} {variants ""}} {
+ global macports::registry.path
+
+ set receipt_path [file join ${macports::registry.path} receipts ${name} ${version}_${revision}${variants}]
+ set receipt_file [file join ${receipt_path} receipt]
+
+ if { [file exists $receipt_file] } {
+ return 1
+ } elseif { [file exists ${receipt_file}.bz2] } {
+ return 1
+ }
+
+ return 0
+}
+
+# Check to see if any entry exists for the given port name
+proc entry_exists_for_name {name} {
+ global macports::registry.path
+
+ set receipt_path [file join ${macports::registry.path} receipts ${name}]
+
+ if {[llength [glob -nocomplain -directory $receipt_path */receipt{,.bz2}]] > 0} {
+ return 1
+ }
+
+ return 0
+}
+
+##
+#
+# Store a property to a receipt that was loaded in memory.
+# This replaces any property that had the same key previously in the receipt.
+#
+# ref reference number for the receipt.
+# property key for the property to store.
+# value value for the property to store.
+proc property_store {ref property value} {
+ variable receipt_$ref
+
+ array set receipt_[set ref] [list $property $value]
+
+ return 1
+}
+
+##
+#
+# Retrieve a property from a receipt that was loaded in memory.
+#
+# ref reference number for the receipt.
+# property key for the property to retrieve.
+#
+proc property_retrieve {ref property} {
+ variable receipt_$ref
+
+ set theCouple [array get receipt_[set ref] $property]
+ if {[llength $theCouple] != 2} {
+ return 0
+ } else {
+ return [lindex $theCouple 1]
+ }
+}
+
+# Delete an entry
+proc delete_entry {name version {revision 0} {variants ""}} {
+ global macports::registry.path
+ variable ref_index
+
+ # if the entry is loaded, purge it
+ if {[info exists ref_index($name,$version,$revision,$variants)]} {
+ set ref $ref_index($name,$version,$revision,$variants)
+ variable receipt_${ref}
+ array unset receipt_${ref}
+ array unset ref_index "$name,$version,$revision,$variants"
+ }
+
+ set receipt_path [file join ${macports::registry.path} receipts ${name} ${version}_${revision}${variants}]
+ if { [file exists ${receipt_path}] } {
+ # remove port receipt directory
+ ui_debug "deleting directory: ${receipt_path}"
+ file delete -force -- ${receipt_path}
+ # remove port receipt parent directory (if empty)
+ set receipt_dir [file join ${macports::registry.path} receipts ${name}]
+ if { [file isdirectory ${receipt_dir}] } {
+ # 0 item means empty.
+ if { [llength [readdir ${receipt_dir}]] == 0 } {
+ ui_debug "deleting directory: ${receipt_dir}"
+ file delete -force -- ${receipt_dir}
+ } else {
+ ui_debug "${receipt_dir} is not empty"
+ }
+ }
+ return 1
+ } else {
+ return 0
+ }
+}
+
+# Return all installed ports
+#
+# If version is "", return all ports of that version.
+# Otherwise, return only ports that exactly match this version.
+# What we call version here is version_revision+variants.
+# Note: at some point we need to change these APIs and support something
+# like selecting on the version or selecting variants in any order.
+proc installed {{name ""} {version ""}} {
+ global macports::registry.path
+
+ set query_path [file join ${macports::registry.path} receipts]
+
+ if { $name == "" } {
+ set query_path [file join ${query_path} *]
+ if { $version == "" } {
+ set query_path [file join ${query_path} *]
+ }
+ # [PG] Huh?
+ } else {
+ # We want to be case-insensitive but case-preserving, so the name gets
+ # returned with the correct case even if it's wrong when given. To get the
+ # correct case on a case-insensitive FS, we have to list the directory and
+ # compare against each entry.
+ set name_path [file join ${query_path} *]
+ set name_entries [glob -nocomplain -types d ${name_path}]
+ foreach entry $name_entries {
+ set basename [file tail $entry]
+ if {[string equal -nocase $basename $name]} {
+ set name $basename
+ break
+ }
+ }
+ set query_path [file join ${query_path} ${name}]
+ if { $version != "" } {
+ set query_path [file join ${query_path} ${version}]
+ } else {
+ set query_path [file join ${query_path} *]
+ }
+ }
+
+ set x [glob -nocomplain -types d ${query_path}]
+ set rlist [list]
+ foreach p $x {
+ if {![file isfile [file join $p receipt.bz2]] && ![file isfile [file join $p receipt]]} {
+ continue
+ }
+ set plist [list]
+ regexp {([-_a-zA-Z0-9\.]+)_([0-9]*)([+-_a-zA-Z0-9]*)$} [lindex [file split $p] end] match version revision variants
+ lappend plist [lindex [file split $p] end-1]
+ lappend plist $version
+ lappend plist $revision
+ lappend plist $variants
+ lappend rlist $plist
+ }
+
+ # append the ports in old HEAD format.
+ if { $name == "" } {
+ set query_path [file join ${macports::registry.path} receipts *]
+ } else {
+ set query_path [file join ${macports::registry.path} receipts ${name}-*]
+ }
+ set receiptglob [glob -nocomplain -types f ${query_path}]
+ foreach receipt_file $receiptglob {
+ set theFileName [file tail $receipt_file]
+
+ # Remark: these regexes do not always work.
+ set theName ""
+ if { $name == "" } {
+ regexp {^(.*)-(.*)$} $theFileName match theName version
+ } else {
+ regexp "^($name)-(.*)\$" $theFileName match theName version
+ }
+
+ # Skip if the name is empty, i.e. if it didn't match.
+ if {[string length $theName]} {
+ set plist [list]
+ lappend plist $theName
+
+ # Remove .bz2 suffix, if present.
+ regexp {^(.*)\.bz2$} $version match version
+ lappend plist $version
+ lappend plist 0
+ lappend plist ""
+ lappend rlist $plist
+ }
+ }
+
+ return $rlist
+}
+
+# File Map stuff
+
+##
+# open the file map and store a reference to it into variable file_map.
+# convert from the old format if required.
+#
+proc open_file_map {{readonly 0}} {
+ global macports::registry.path
+ variable file_map
+
+ set receipt_path [file join ${macports::registry.path} receipts]
+ set map_file [file join ${receipt_path} file_map]
+
+ # Don't reopen it (it actually would deadlock us), unless it was open r/o.
+ # and we want it r/w.
+ if { [info exists file_map] } {
+ if { $readonly == 0 } {
+ if {[filemap isreadonly file_map]} {
+ filemap close file_map
+ filemap open file_map ${map_file}.db
+ }
+ }
+ return 0
+ }
+
+ set old_filemap [list]
+
+ if { ![file exists ${map_file}.db] } {
+ # Convert to new format
+ if { [file exists ${map_file}.bz2] && [file exists ${registry::autoconf::bzip2_path}] } {
+ set old_filemap [exec ${registry::autoconf::bzip2_path} -d -c ${map_file}.bz2]
+ } elseif { [file exists $map_file] } {
+ set map_handle [open ${map_file} r]
+ set old_filemap [read $map_handle]
+ close $map_handle
+ }
+ }
+
+ if { [llength $old_filemap] > 0 } {
+ # Translate from old format.
+ # Open the map (new format)
+ filemap open file_map ${map_file}.db
+
+ # Tell the user.
+ ui_msg "Converting file map to new format (this may take a while)"
+
+ foreach f $old_filemap {
+ filemap set file_map [lindex $f 0] [lindex $f 1]
+ }
+
+ # Save it afterwards.
+ filemap save file_map
+
+ # reopen it r/o if we wanted it r/o.
+ } else {
+ # open it directly
+ if { $readonly == 1 } {
+ filemap open file_map ${map_file}.db readonly
+ } else {
+ filemap open file_map ${map_file}.db
+ }
+ }
+
+ return 0
+}
+
+##
+# determine if a file is registered in the file map, and if it is,
+# get its port.
+# open the file map if required.
+#
+# - file the file to test
+# return the 0 if the file is not registered, the name of the port otherwise.
+#
+proc file_registered {file} {
+ variable file_map
+
+ open_file_map 1
+
+ if {[filemap exists file_map $file]} {
+ return [filemap get file_map $file]
+ } else {
+ return 0
+ }
+}
+
+##
+# determine if a port is registered in the file map, and if it is,
+# get its installed (activated) files.
+# convert the port if required.
+# open the file map if required.
+#
+# - port the port to test
+# return the 0 if the port is not registered, the list of its files otherwise.
+#
+proc port_registered {name} {
+ # Trust the file map first.
+ variable file_map
+
+ open_file_map 1
+
+ set files [filemap list file_map $name]
+
+ if { [llength $files] > 0 } {
+ return $files
+ } else {
+ # Is port installed?
+ set matchingPorts [installed $name]
+ if { [llength $matchingPorts] } {
+ # Convert the port and retry.
+ open_entry $name
+
+ set files [filemap list file_map $name]
+
+ return $files
+ } else {
+ return 0
+ }
+ }
+}
+
+##
+# register a file in the file map.
+# open the file map if required.
+#
+# - file the file to register
+# - port the port to associate with the file
+#
+proc register_file {file port} {
+ variable file_map
+
+ open_file_map
+
+ if { [file type $file] == "link" } {
+ ui_debug "Adding link to file_map: $file for: $port"
+ } else {
+ ui_debug "Adding file to file_map: $file for: $port"
+ }
+ filemap set file_map $file $port
+}
+
+##
+# register all the files in the list 'files' in the filemap.
+# open the file map if required.
+#
+# - files the list of files to register
+# - port the port to associate the files with
+#
+proc register_bulk_files {files port} {
+ variable file_map
+
+ open_file_map
+
+ foreach f $files {
+ set file [lindex $f 0]
+ if { [file type $file] == "link" } {
+ ui_debug "Adding link to file_map: $file for: $port"
+ } else {
+ ui_debug "Adding file to file_map: $file for: $port"
+ }
+ filemap set file_map $file $port
+ }
+}
+
+##
+# unregister a file from the file map.
+# open the file map if required.
+#
+# - file the file to unregister
+#
+proc unregister_file {file} {
+ variable file_map
+
+ open_file_map
+
+ ui_debug "Removing entry from file_map: $file"
+ filemap unset file_map $file
+}
+
+##
+# save the file map to disk.
+# do not do anything if the file map wasn't open.
+#
+# always return 1
+#
+proc write_file_map {args} {
+ variable file_map
+
+ if { [info exists file_map] } {
+ open_file_map
+ filemap save file_map
+ }
+
+ return 1
+}
+
+##
+# close the file map.
+# important to do this so the lock is released.
+# do not do anything if the file map wasn't open.
+#
+proc close_file_map {args} {
+ variable file_map
+
+ if { [info exists file_map] } {
+ filemap close file_map
+ }
+}
+
+# Dependency Map Code
+proc open_dep_map {args} {
+ global macports::registry.path
+ variable dep_map
+
+ set receipt_path [file join ${macports::registry.path} receipts]
+
+ set map_file [file join ${receipt_path} dep_map]
+
+ if { [file exists ${map_file}.bz2] && [file exists ${registry::autoconf::bzip2_path}] } {
+ set dep_map [exec ${registry::autoconf::bzip2_path} -d -c ${map_file}.bz2]
+ } elseif { [file exists ${map_file}] } {
+ set map_handle [open ${map_file} r]
+ set dep_map [read $map_handle]
+ close $map_handle
+ } else {
+ set dep_map [list]
+ }
+ if { ![llength $dep_map] > 0 } {
+ set dep_map [list]
+ }
+}
+
+# List all ports this one depends on
+proc list_depends {name} {
+ variable dep_map
+ if { [llength $dep_map] < 1 && [info exists dep_map] } {
+ open_dep_map
+ }
+ set rlist [list]
+ foreach de $dep_map {
+ if { $name == [lindex $de 2] } {
+ lappend rlist $de
+ }
+ }
+ return $rlist
+}
+
+# List all the ports that depend on this port
+proc list_dependents {name} {
+ variable dep_map
+ if { [llength $dep_map] < 1 && [info exists dep_map] } {
+ open_dep_map
+ }
+ set rlist [list]
+ foreach de $dep_map {
+ if { $name == [lindex $de 0] } {
+ lappend rlist $de
+ }
+ }
+ return $rlist
+}
+
+proc register_dep {dep type port} {
+ variable dep_map
+ set newdep [list $dep $type $port]
+ # slow, but avoids duplicate entries building up
+ if {[lsearch -exact $dep_map $newdep] == -1} {
+ lappend dep_map $newdep
+ }
+}
+
+proc unregister_dep {dep type port} {
+ variable dep_map
+ set new_map [list]
+ foreach de $dep_map {
+ if { $de != [list $dep $type $port] } {
+ lappend new_map $de
+ }
+ }
+ set dep_map $new_map
+}
+
+# remove duplicate entries from the dep_map
+# (could be put there by older versions of MacPorts)
+proc clean_dep_map {args} {
+ variable dep_map
+ set new_map [list]
+ set oldlen [llength $dep_map]
+ ui_debug "Current dep_map has $oldlen entries"
+ foreach de $dep_map {
+ if {[lsearch -exact $new_map $de] == -1} {
+ lappend new_map $de
+ } else {
+ ui_debug "Removing $de from dep_map"
+ }
+ }
+ set dep_map $new_map
+
+ set newlen [llength $dep_map]
+ set diff [expr $oldlen - $newlen]
+ ui_debug "New dep_map has $newlen entries"
+ ui_info "Removed $diff duplicate entries from the dependency map"
+}
+
+proc write_dep_map {args} {
+ global macports::registry.path
+ variable dep_map
+
+ set receipt_path [file join ${macports::registry.path} receipts]
+
+ set map_file [file join ${receipt_path} dep_map]
+
+ set map_handle [open ${map_file}.tmp w 0644]
+ puts $map_handle $dep_map
+ close $map_handle
+
+ # don't both checking for presence, file delete doesn't error if file doesn't exist
+ file delete -- ${map_file} ${map_file}.bz2
+
+ file rename -- ${map_file}.tmp ${map_file}
+
+ if { [file exists ${map_file}] && [file exists ${registry::autoconf::bzip2_path}] && ![info exists registry.nobzip] } {
+ system "${registry::autoconf::bzip2_path} -f ${map_file}"
+ }
+
+ return 1
+}
+
+# End of receipt_flat namespace
+}
+
Copied: trunk/base/src/registry2.0/registry.tcl (from rev 63371, trunk/base/src/registry1.0/registry.tcl)
===================================================================
--- trunk/base/src/registry2.0/registry.tcl (rev 0)
+++ trunk/base/src/registry2.0/registry.tcl 2010-02-04 00:46:00 UTC (rev 63398)
@@ -0,0 +1,396 @@
+# registry.tcl
+#
+# 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 registry 1.0
+
+package require macports 1.0
+package require receipt_flat 1.0
+package require portimage 2.0
+package require portuninstall 2.0
+package require msgcat
+
+namespace eval registry {
+
+# 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} } {
+ global macports::registry.path macports::registry.format macports::registry.installtype macports::prefix
+
+
+ # Make sure we don't already have an entry in the Registry for this
+ # port version_revision+variants
+ if {![entry_exists $name $version $revision $variants] } {
+
+ set ref [${macports::registry.format}::new_entry]
+
+ property_store $ref name $name
+ property_store $ref version $version
+ property_store $ref revision $revision
+ property_store $ref variants $variants
+ property_store $ref epoch $epoch
+ # Trick to have a portable GMT-POSIX epoch-based time.
+ # (because we'll compare this with a file mtime).
+ property_store $ref date [expr [clock scan now -gmt true] - [clock scan "1970-1-1 00:00:00" -gmt true]]
+ property_store $ref installtype ${macports::registry.installtype}
+ property_store $ref receipt_f ${macports::registry.format}
+ if { ${macports::registry.installtype} == "image" } {
+ set imagedir [file join ${macports::registry.path} software ${name} ${version}_${revision}${variants}]
+ property_store $ref imagedir $imagedir
+ property_store $ref active 0
+ }
+
+ return $ref
+ } else {
+ return -code error "Registry error: ${name} @${version}_${revision}${variants} already registered as installed. Please uninstall it first."
+ }
+}
+
+# Check to see if an entry exists in the registry. This is passed straight
+# through to the receipts system
+proc entry_exists {name version {revision 0} {variants ""}} {
+ global macports::registry.format
+ return [${macports::registry.format}::entry_exists $name $version $revision $variants]
+}
+
+# Check to see if any entry exists in the registry for the given port name.
+proc entry_exists_for_name {name} {
+ global macports::registry.format
+ return [${macports::registry.format}::entry_exists_for_name $name]
+}
+
+# Close the registry... basically wrap the receipts systems's write process
+proc write_entry {ref} {
+ global macports::registry.format
+
+ set name [property_retrieve $ref name]
+ set version [property_retrieve $ref version]
+ set revision [property_retrieve $ref revision]
+ set variants [property_retrieve $ref variants]
+ set epoch [property_retrieve $ref epoch]
+ set contents [property_retrieve $ref contents]
+
+ ${macports::registry.format}::write_entry $ref $name $version $revision $variants
+
+}
+
+# Delete an entry from the registry.
+proc delete_entry {ref} {
+ global macports::registry.format
+
+ set name [property_retrieve $ref name]
+ set version [property_retrieve $ref version]
+ set revision [property_retrieve $ref revision]
+ set variants [property_retrieve $ref variants]
+
+ ${macports::registry.format}::delete_entry $name $version $revision $variants
+
+}
+
+# Open a registry entry.
+proc open_entry {name {version ""} {revision 0} {variants ""}} {
+ global macports::registry.format
+
+ return [${macports::registry.format}::open_entry $name $version $revision $variants]
+
+}
+
+# Store a property with the open registry entry.
+proc property_store {ref property value} {
+ global macports::registry.format
+ ${macports::registry.format}::property_store $ref $property $value
+}
+
+# Retrieve a property from the open registry entry.
+proc property_retrieve {ref property} {
+ global macports::registry.format
+ return [${macports::registry.format}::property_retrieve $ref $property]
+}
+
+# If only one version of the port is installed, this process returns that
+# version's parts. Otherwise, it lists the versions installed and exists.
+proc installed {{name ""} {version ""}} {
+ global macports::registry.format
+
+ set ilist [${macports::registry.format}::installed $name $version]
+ set rlist [list]
+
+ if { [llength $ilist] > 1 } {
+ foreach installed $ilist {
+ set iname [lindex $installed 0]
+ set iversion [lindex $installed 1]
+ set irevision [lindex $installed 2]
+ set ivariants [lindex $installed 3]
+ set iref [open_entry $iname $iversion $irevision $ivariants]
+ set iactive [property_retrieve $iref active]
+ set iepoch [property_retrieve $iref epoch]
+ lappend rlist [list $iname $iversion $irevision $ivariants $iactive $iepoch]
+ }
+ } elseif { [llength $ilist] < 1 } {
+ if { $name == "" } {
+ return -code error "Registry error: No ports registered as installed."
+ } else {
+ if { $version == "" } {
+ return -code error "Registry error: $name not registered as installed."
+ } else {
+ return -code error "Registry error: $name $version not registered as installed."
+ }
+ }
+ } else {
+ set iname [lindex [lindex $ilist 0] 0]
+ set iversion [lindex [lindex $ilist 0] 1]
+ set irevision [lindex [lindex $ilist 0] 2]
+ set ivariants [lindex [lindex $ilist 0] 3]
+ set iref [open_entry $iname $iversion $irevision $ivariants]
+ set iactive [property_retrieve $iref active]
+ set iepoch [property_retrieve $iref epoch]
+ lappend rlist [list $iname $iversion $irevision $ivariants $iactive $iepoch]
+ }
+ return $rlist
+}
+
+# Return a list with the active version of a port (or the active versions of
+# all ports if name is "").
+proc active {{name ""}} {
+ global macports::registry.format
+
+ set ilist [${macports::registry.format}::installed $name]
+ set rlist [list]
+
+ if { [llength $ilist] > 0 } {
+ foreach installed $ilist {
+ set iname [lindex $installed 0]
+ set iversion [lindex $installed 1]
+ set irevision [lindex $installed 2]
+ set ivariants [lindex $installed 3]
+ set iref [open_entry $iname $iversion $irevision $ivariants]
+ set iactive [property_retrieve $iref active]
+ set iepoch [property_retrieve $iref epoch]
+ if {$iactive} {
+ lappend rlist [list $iname $iversion $irevision $ivariants $iactive $iepoch]
+ }
+ }
+ }
+
+ if { [llength $rlist] < 1 } {
+ if { $name == "" } {
+ return -code error "Registry error: No ports registered as active."
+ } else {
+ return -code error "Registry error: $name not registered as installed & active."
+ }
+ }
+ return $rlist
+}
+
+proc location {portname portversion} {
+ set ilist [registry::installed $portname $portversion]
+
+ if { [llength $ilist] > 1 } {
+ puts "The following versions of $portname 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 } {
+ puts " $iname @${iversion}_${irevision}${ivariants}"
+ } elseif { $iactive == 1 } {
+ puts " $iname @${iversion}_${irevision}${ivariants} (active)"
+ }
+ }
+ return -1
+ } else {
+ return [lindex $ilist 0]
+ }
+}
+
+
+# File Map Code
+proc open_file_map {args} {
+ global macports::registry.format
+ return [${macports::registry.format}::open_file_map $args]
+}
+
+proc file_registered {file} {
+ global macports::registry.format
+ return [${macports::registry.format}::file_registered $file]
+}
+
+proc port_registered {name} {
+ global macports::registry.format
+ return [${macports::registry.format}::port_registered $name]
+}
+
+proc register_file {file port} {
+ global macports::registry.format
+ return [${macports::registry.format}::register_file $file $port]
+}
+
+proc register_bulk_files {files port} {
+ global macports::registry.format
+ open_file_map
+ set r [${macports::registry.format}::register_bulk_files $files $port]
+ write_file_map
+ close_file_map
+ return $r
+}
+
+proc unregister_file {file} {
+ global macports::registry.format
+ return [${macports::registry.format}::unregister_file $file]
+}
+
+proc write_file_map {args} {
+ global macports::registry.format
+ return [${macports::registry.format}::write_file_map $args]
+}
+
+proc close_file_map {args} {
+ global macports::registry.format
+ return [${macports::registry.format}::close_file_map $args]
+}
+
+# Dependency Map Code
+proc register_dependencies {deps name} {
+
+ open_dep_map
+ foreach dep $deps {
+ # We expect the form type:regexp:port to come in, but we don't need to
+ # store it that way in the dep map.
+ set type [lindex [split $dep :] 0]
+ set depport [lindex [split $dep :] end]
+ register_dep $depport $type $name
+ }
+ write_dep_map
+}
+
+proc unregister_dependencies {name} {
+
+ open_dep_map
+ foreach dep [list_depends $name] {
+ unregister_dep [lindex $dep 0] [lindex $dep 1] [lindex $dep 2]
+ }
+ write_dep_map
+}
+
+proc open_dep_map {args} {
+ global macports::registry.format
+ return [${macports::registry.format}::open_dep_map $args]
+}
+
+##
+#
+# From a file name, return a list representing data currently known about the file.
+# This list is a 6-tuple of the form:
+# 0: file path
+# 1: uid
+# 2: gid
+# 3: mode
+# 4: size
+# 5: md5 checksum information
+#
+# fname a path to a given file.
+# return a 6-tuple about this file.
+proc fileinfo_for_file {fname} {
+ # Add the link to the registry, not the actual file.
+ # (we won't store the md5 of the target of links since it's meaningless
+ # and $statvar(mode) tells us that links are links).
+ if {![catch {file lstat $fname statvar}]} {
+ if {[file isfile $fname] && [file type $fname] != "link"} {
+ if {[catch {md5 file $fname} md5sum] == 0} {
+ # Create a line that matches md5(1)'s output
+ # for backwards compatibility
+ set line "MD5 ($fname) = $md5sum"
+ return [list $fname $statvar(uid) $statvar(gid) $statvar(mode) $statvar(size) $line]
+ }
+ } else {
+ return [list $fname $statvar(uid) $statvar(gid) $statvar(mode) $statvar(size) "MD5 ($fname) NONE"]
+ }
+ }
+ return {}
+}
+
+##
+#
+# From a list of files, return a list of information concerning these files.
+# The information is obtained through fileinfo_for_file.
+#
+# flist the list of file to get information about.
+# return a list of 6-tuples described in fileinfo_for_file.
+proc fileinfo_for_index {flist} {
+ global prefix
+
+ set rval [list]
+ foreach file $flist {
+ if {[string index $file 0] != "/"} {
+ set file [file join $prefix $file]
+ }
+ lappend rval [fileinfo_for_file $file]
+ }
+ return $rval
+}
+
+# List all ports this one depends on
+proc list_depends {name} {
+ global macports::registry.format
+ return [${macports::registry.format}::list_depends $name]
+}
+
+# List all the ports that depend on this port
+proc list_dependents {name} {
+ global macports::registry.format
+ return [${macports::registry.format}::list_dependents $name]
+}
+
+proc register_dep {dep type port} {
+ global macports::registry.format
+ return [${macports::registry.format}::register_dep $dep $type $port]
+}
+
+proc unregister_dep {dep type port} {
+ global macports::registry.format
+ return [${macports::registry.format}::unregister_dep $dep $type $port]
+}
+
+proc clean_dep_map {args} {
+ global macports::registry.format
+ return [${macports::registry.format}::clean_dep_map $args]
+}
+
+proc write_dep_map {args} {
+ global macports::registry.format
+ return [${macports::registry.format}::write_dep_map $args]
+}
+
+
+# End of registry namespace
+}
+
Copied: trunk/base/src/registry2.0/registry_autoconf.tcl.in (from rev 63371, trunk/base/src/registry1.0/registry_autoconf.tcl.in)
===================================================================
--- trunk/base/src/registry2.0/registry_autoconf.tcl.in (rev 0)
+++ trunk/base/src/registry2.0/registry_autoconf.tcl.in 2010-02-04 00:46:00 UTC (rev 63398)
@@ -0,0 +1,35 @@
+# registry_autoconf.tcl.in
+# $Id$
+#
+# Copyright (c) 2007 Kevin Ballard <eridius at macports.org>
+# 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 registry 1.0
+
+namespace eval registry::autoconf {
+ variable bzip2_path "@BZIP2@"
+}
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://lists.macosforge.org/pipermail/macports-changes/attachments/20100203/af85f1b5/attachment-0001.html>
More information about the macports-changes
mailing list