[123748] branches/gsoc14-cleanup/src/port
ksammons at macports.org
ksammons at macports.org
Wed Aug 13 15:14:53 PDT 2014
Revision: 123748
https://trac.macports.org/changeset/123748
Author: ksammons at macports.org
Date: 2014-08-13 15:14:53 -0700 (Wed, 13 Aug 2014)
Log Message:
-----------
Final (hopefully) changes
Removed Paths:
-------------
branches/gsoc14-cleanup/src/port/port.BACKUP.23878
branches/gsoc14-cleanup/src/port/port.BASE.23878
branches/gsoc14-cleanup/src/port/port.LOCAL.23878
branches/gsoc14-cleanup/src/port/port.REMOTE.23878
branches/gsoc14-cleanup/src/port/port.orig
branches/gsoc14-cleanup/src/port/port.tcl.orig
Deleted: branches/gsoc14-cleanup/src/port/port.BACKUP.23878
===================================================================
--- branches/gsoc14-cleanup/src/port/port.BACKUP.23878 2014-08-13 22:14:51 UTC (rev 123747)
+++ branches/gsoc14-cleanup/src/port/port.BACKUP.23878 2014-08-13 22:14:53 UTC (rev 123748)
@@ -1,5362 +0,0 @@
-#!/opt/local/libexec/macports/bin/tclsh8.5
-# -*- coding: utf-8; mode: tcl; tab-width: 4; indent-tabs-mode: nil; c-basic-offset: 4 -*- vim:fenc=utf-8:filetype=tcl:et:sw=4:ts=4:sts=4
-# $Id: port.tcl 119177 2014-04-18 22:35:29Z cal at macports.org $
-#
-# Copyright (c) 2004-2014 The MacPorts Project
-# Copyright (c) 2004 Robert Shaw <rshaw at opendarwin.org>
-# Copyright (c) 2002-2003 Apple 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 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.
-
-# Create a namespace for some local variables
-namespace eval portclient::progress {
- ##
- # Indicate whether the term::ansi::send tcllib package is available and was
- # imported. "yes", if the package is available, "no" otherwise.
- variable hasTermAnsiSend no
-}
-
-if {![catch {package require term::ansi::send}]} {
- set portclient::progress::hasTermAnsiSend yes
-}
-
-package require macports
-package require Pextlib 1.0
-
-# Standard procedures
-proc print_usage {{verbose 1}} {
- global cmdname
- set syntax {
- [-bcdfknopqRstuvy] [-D portdir] [-F cmdfile] action [privopts] [actionflags]
- [[portname|pseudo-portname|port-url] [@version] [+-variant]... [option=value]...]...
- }
-
- if {$verbose} {
- puts stderr "Usage: $cmdname$syntax"
- puts stderr "\"$cmdname help\" or \"man 1 port\" for more information."
- } else {
- puts stderr "$cmdname$syntax"
- }
-}
-
-proc print_help {args} {
- global action_array
-
- print_usage 0
-
- # Generate and format the command list from the action_array
- set cmds ""
- set lineLen 0
- foreach cmd [lsort [array names action_array]] {
- if {$lineLen > 65} {
- set cmds "$cmds,\n"
- set lineLen 0
- }
- if {$lineLen == 0} {
- set new "$cmd"
- } else {
- set new ", $cmd"
- }
- incr lineLen [string length $new]
- set cmds "$cmds$new"
- }
-
- set cmdText "Supported actions
-------------------
-$cmds
-"
-
- set text {
-Pseudo-portnames
-----------------
-Pseudo-portnames are words that may be used in place of a portname, and
-which expand to some set of ports. The common pseudo-portnames are:
-all, current, active, inactive, actinact, installed, uninstalled, outdated,
-obsolete, requested, unrequested and leaves.
-These pseudo-portnames expand to the set of ports named.
-
-Pseudo-portnames starting with variants:, variant:, description:, depends:,
-depends_lib:, depends_run:, depends_build:, depends_fetch:, depends_extract:,
-portdir:, homepage:, epoch:, platforms:, platform:, name:, long_description:,
-maintainers:, maintainer:, categories:, category:, version:, revision:, and
-license: each select a set of ports based on a regex search of metadata
-about the ports. In all such cases, a standard regex pattern following
-the colon will be used to select the set of ports to which the
-pseudo-portname expands.
-
-Pseudo-portnames starting with depof:, rdepof:, dependentof:, and rdependentof:
-select ports that are direct or recursive dependencies or dependents of the
-following portname, respectively.
-
-Portnames that contain standard glob characters will be expanded to the
-set of ports matching the glob pattern.
-
-Port expressions
-----------------
-Portnames, port glob patterns, and pseudo-portnames may be logically
-combined using expressions consisting of and, or, not, !, (, and ).
-
-For more information
---------------------
-See man pages: port(1), macports.conf(5), portfile(7), portgroup(7),
-porthier(7), portstyle(7). Also, see http://www.macports.org.
- }
-
- puts "$cmdText$text"
-}
-
-
-# Produce error message and exit
-proc fatal s {
- global argv0
- ui_error "$argv0: $s"
- exit 1
-}
-
-##
-# Helper function to define constants
-#
-# Constants defined with const can simply be accessed in the same way as
-# calling a proc.
-#
-# Example:
-# const FOO 42
-# puts [FOO]
-#
-# @param name variable name
-# @param value constant variable value
-proc const {name args} {
- proc $name {} [list return [expr $args]]
-}
-
-# Format an integer representing bytes using given units
-proc bytesize {siz {unit {}} {format {%.3f}}} {
- if {$unit == {}} {
- if {$siz > 0x40000000} {
- set unit "GiB"
- } elseif {$siz > 0x100000} {
- set unit "MiB"
- } elseif {$siz > 0x400} {
- set unit "KiB"
- } else {
- set unit "B"
- }
- }
- switch -- $unit {
- KiB {
- set siz [expr {$siz / 1024.0}]
- }
- kB {
- set siz [expr {$siz / 1000.0}]
- }
- MiB {
- set siz [expr {$siz / 1048576.0}]
- }
- MB {
- set siz [expr {$siz / 1000000.0}]
- }
- GiB {
- set siz [expr {$siz / 1073741824.0}]
- }
- GB {
- set siz [expr {$siz / 1000000000.0}]
- }
- B { }
- default {
- ui_warn "Unknown file size unit '$unit' specified"
- set unit "B"
- }
- }
- if {[expr {round($siz)}] != $siz} {
- set siz [format $format $siz]
- }
- return "$siz $unit"
-}
-
-proc filesize {fil {unit {}}} {
- set siz {@}
- catch {
- set siz [bytesize [file size $fil] $unit]
- }
- return $siz
-}
-
-# Produce an error message, and exit, unless
-# we're handling errors in a soft fashion, in which
-# case we continue
-proc fatal_softcontinue s {
- if {[macports::global_option_isset ports_force]} {
- ui_error $s
- return -code continue
- } else {
- fatal $s
- }
-}
-
-
-# Produce an error message, and break, unless
-# we're handling errors in a soft fashion, in which
-# case we continue
-proc break_softcontinue { msg status name_status } {
- upvar $name_status status_var
- ui_error $msg
- if {[macports::ui_isset ports_processall]} {
- set status_var 0
- return -code continue
- } else {
- set status_var $status
- return -code break
- }
-}
-
-# show the URL for the ticket reporting instructions
-proc print_tickets_url {args} {
- if {${macports::prefix} ne "/usr/local" && ${macports::prefix} ne "/usr"} {
- ui_error "Follow http://guide.macports.org/#project.tickets to report a bug."
- }
-}
-
-# Form a composite version as is sometimes used for registry functions
-# This function sorts the variants and presents them in a canonical representation
-proc composite_version {version variations {emptyVersionOkay 0}} {
- # Form a composite version out of the version and variations
-
- # Select the variations into positive and negative
- set pos {}
- set neg {}
- foreach { key val } $variations {
- if {$val eq "+"} {
- lappend pos $key
- } elseif {$val eq "-"} {
- lappend neg $key
- }
- }
-
- # If there is no version, we have nothing to do
- set composite_version ""
- if {$version ne "" || $emptyVersionOkay} {
- set pos_str ""
- set neg_str ""
-
- if {[llength $pos]} {
- set pos_str "+[join [lsort -ascii $pos] "+"]"
- }
- if {[llength $neg]} {
- set neg_str "-[join [lsort -ascii $neg] "-"]"
- }
-
- set composite_version "$version$pos_str$neg_str"
- }
-
- return $composite_version
-}
-
-
-proc split_variants {variants} {
- set result {}
- set l [regexp -all -inline -- {([-+])([[:alpha:]_]+[\w\.]*)} $variants]
- foreach { match sign variant } $l {
- lappend result $variant $sign
- }
- return $result
-}
-
-
-##
-# Maps friendly field names to their real name
-# Names which do not need mapping are not changed.
-#
-# @param field friendly name
-# @return real name
-proc map_friendly_field_names { field } {
- switch -- $field {
- variant -
- platform -
- maintainer -
- subport {
- set field "${field}s"
- }
- category {
- set field "categories"
- }
- }
-
- return $field
-}
-
-
-proc registry_installed {portname {portversion ""}} {
- set ilist [registry::installed $portname $portversion]
- if { [llength $ilist] > 1 } {
- # set portname again since the one we were passed may not have had the correct case
- set portname [lindex $ilist 0 0]
- ui_notice "The following versions of $portname are currently installed:"
- foreach i [portlist_sortint $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 -code error "Registry error: Please specify the full version as recorded in the port registry."
- } else {
- return [lindex $ilist 0]
- }
-}
-
-
-proc entry_for_portlist {portentry} {
- global global_options global_variations
-
- # Each portlist entry currently has the following elements in it:
- # url if any
- # name
- # version (version_revision)
- # variants array (variant=>+-)
- # requested_variants array (variant=>+-)
- # options array (key=>value)
- # fullname (name/version_revision+-variants)
-
- array set port $portentry
- if {![info exists port(url)]} { set port(url) "" }
- if {![info exists port(name)]} { set port(name) "" }
- if {![info exists port(version)]} { set port(version) "" }
- if {![info exists port(variants)]} { set port(variants) "" }
- if {![info exists port(requested_variants)]} { set port(requested_variants) "" }
- if {![info exists port(options)]} { set port(options) [array get global_options] }
-
- # If neither portname nor url is specified, then default to the current port
- if { $port(url) eq "" && $port(name) eq "" } {
- set url file://.
- set portname [url_to_portname $url]
- set port(url) $url
- set port(name) $portname
- if {$portname eq ""} {
- ui_error "A default port name could not be supplied."
- }
- }
-
- # Form the fully discriminated portname: portname/version_revison+-variants
- set port(fullname) "$port(name)/[composite_version $port(version) $port(variants)]"
-
- return [array get port]
-}
-
-
-proc add_to_portlist {listname portentry} {
- upvar $listname portlist
-
- # Form portlist entry and add to portlist
- lappend portlist [entry_for_portlist $portentry]
-}
-
-
-proc add_ports_to_portlist {listname ports {overridelist ""}} {
- upvar $listname portlist
-
- array set overrides $overridelist
-
- # Add each entry to the named portlist, overriding any values
- # specified as overrides
- foreach portentry $ports {
- array set port $portentry
- if ([info exists overrides(version)]) { set port(version) $overrides(version) }
- if ([info exists overrides(variants)]) { set port(variants) $overrides(variants) }
- if ([info exists overrides(requested_variants)]) { set port(requested_variants) $overrides(requested_variants) }
- if ([info exists overrides(options)]) { set port(options) $overrides(options) }
- add_to_portlist portlist [array get port]
- }
-}
-
-
-proc url_to_portname { url {quiet 0} } {
- # Save directory and restore the directory, since mportopen changes it
- set savedir [pwd]
- set portname ""
- if {[catch {set ctx [mportopen $url]} result]} {
- if {!$quiet} {
- ui_msg "Can't map the URL '$url' to a port description file (\"${result}\")."
- ui_msg "Please verify that the directory and portfile syntax are correct."
- }
- } else {
- array set portinfo [mportinfo $ctx]
- set portname $portinfo(name)
- mportclose $ctx
- }
- cd $savedir
- return $portname
-}
-
-
-# Supply a default porturl/portname if the portlist is empty
-proc require_portlist { nameportlist {is_upgrade "no"} } {
- global private_options
- upvar $nameportlist portlist
-
- if {[llength $portlist] == 0 && (![info exists private_options(ports_no_args)] || $private_options(ports_no_args) eq "no")} {
- if {${is_upgrade} == "yes"} {
- # $> port upgrade outdated
- # Error: No ports matched the given expression
- # is not very user friendly - if we're in the special case of
- # "upgrade", let's print a message that's a little easier to
- # understand and less alarming.
- ui_msg "Nothing to upgrade."
- return 1
- }
- ui_error "No ports matched the given expression"
- return 1
- }
-
- if {[llength $portlist] == 0} {
- set portlist [get_current_port]
-
- if {[llength $portlist] == 0} {
- # there was no port in current directory
- return 1
- }
- }
-
- return 0
-}
-
-
-# Execute the enclosed block once for every element in the portlist
-# When the block is entered, the following variables will have been set:
-# portspec, porturl, portname, portversion, options, variations, requested_variations
-proc foreachport {portlist block} {
- set savedir [pwd]
- foreach portspec $portlist {
-
- # Set the variables for the block
- uplevel 1 "array unset portspec; array set portspec { $portspec }"
- uplevel 1 {
- set porturl $portspec(url)
- set portname $portspec(name)
- set portversion $portspec(version)
- array unset variations
- array set variations $portspec(variants)
- array unset requested_variations
- array set requested_variations $portspec(requested_variants)
- array unset options
- array set options $portspec(options)
- }
-
- # Invoke block
- uplevel 1 $block
-
- # Restore cwd after each port, since mportopen changes it, and otherwise relative
- # urls would break on subsequent passes
- if {[file exists $savedir]} {
- cd $savedir
- } else {
- cd ~
- }
- }
-}
-
-
-proc portlist_compare { a b } {
- array set a_ $a
- array set b_ $b
- set namecmp [string equal -nocase $a_(name) $b_(name)]
- if {$namecmp != 1} {
- if {$a_(name) eq [lindex [lsort -dictionary [list $a_(name) $b_(name)]] 0]} {
- return -1
- }
- return 1
- }
- set avr_ [split $a_(version) "_"]
- set bvr_ [split $b_(version) "_"]
- set versioncmp [vercmp [lindex $avr_ 0] [lindex $bvr_ 0]]
- if {$versioncmp != 0} {
- return $versioncmp
- }
- set ar_ [lindex $avr_ 1]
- set br_ [lindex $bvr_ 1]
- if {$ar_ < $br_} {
- return -1
- } elseif {$ar_ > $br_} {
- return 1
- } else {
- return 0
- }
-}
-
-# Sort two ports in NVR (name at version_revision) order
-proc portlist_sort { list } {
- return [lsort -command portlist_compare $list]
-}
-
-proc portlist_compareint { a b } {
- array set a_ [list "name" [lindex $a 0] "version" "[lindex $a 1]_[lindex $a 2]"]
- array set b_ [list "name" [lindex $b 0] "version" "[lindex $b 1]_[lindex $b 2]"]
- return [portlist_compare [array get a_] [array get b_]]
-}
-
-# Same as portlist_sort, but with numeric indexes {name version revision}
-proc portlist_sortint { list } {
- return [lsort -command portlist_compareint $list]
-}
-
-# sort portlist so dependents come before their dependencies
-proc portlist_sortdependents { portlist } {
- foreach p $portlist {
- array set pvals $p
- lappend entries($pvals(name)) $p
- if {![info exists dependents($pvals(name))]} {
- set dependents($pvals(name)) {}
- foreach result [registry::list_dependents $pvals(name)] {
- lappend dependents($pvals(name)) [lindex $result 2]
- }
- }
- array unset pvals
- }
- set ret {}
- foreach p $portlist {
- portlist_sortdependents_helper $p entries dependents seen ret
- }
- return $ret
-}
-
-proc portlist_sortdependents_helper {p up_entries up_dependents up_seen up_retlist} {
- upvar $up_seen seen
- if {![info exists seen($p)]} {
- set seen($p) 1
- upvar $up_entries entries $up_dependents dependents $up_retlist retlist
- array set pvals $p
- foreach dependent $dependents($pvals(name)) {
- if {[info exists entries($dependent)]} {
- foreach entry $entries($dependent) {
- portlist_sortdependents_helper $entry entries dependents seen retlist
- }
- }
- }
- lappend retlist $p
- }
-}
-
-proc regex_pat_sanitize { s } {
- set sanitized [regsub -all {[\\(){}+$.^]} $s {\\&}]
- return $sanitized
-}
-
-##
-# Makes sure we get the current terminal size
-proc term_init_size {} {
- global env
-
- if {![info exists env(COLUMNS)] || ![info exists env(LINES)]} {
- if {[isatty stdout]} {
- set size [term_get_size stdout]
-
- if {![info exists env(LINES)] && [lindex $size 0] > 0} {
- set env(LINES) [lindex $size 0]
- }
-
- if {![info exists env(COLUMNS)] && [lindex $size 1] > 0} {
- set env(COLUMNS) [lindex $size 1]
- }
- }
- }
-}
-
-##
-# Wraps a multi-line string at specified textwidth
-#
-# @see wrapline
-#
-# @param string input string
-# @param maxlen text width (0 defaults to current terminal width)
-# @param indent prepend to every line
-# @return wrapped string
-proc wrap {string maxlen {indent ""} {indentfirstline 1}} {
- global env
-
- if {$maxlen == 0} {
- if {![info exists env(COLUMNS)]} {
- # no width for wrapping
- return $string
- }
- set maxlen $env(COLUMNS)
- }
-
- set splitstring {}
- set indentline $indentfirstline
- foreach line [split $string "\n"] {
- lappend splitstring [wrapline $line $maxlen $indent $indentline]
- set indentline 1
- }
- return [join $splitstring "\n"]
-}
-
-##
-# Wraps a line at specified textwidth
-#
-# @see wrap
-#
-# @param line input line
-# @param maxlen text width (0 defaults to current terminal width)
-# @param indent prepend to every line
-# @return wrapped string
-proc wrapline {line maxlen {indent ""} {indentfirstline 1}} {
- global env
-
- if {$maxlen == 0} {
- if {![info exists env(COLUMNS)]} {
- # no width for wrapping
- return $string
- }
- set maxlen $env(COLUMNS)
- }
-
- set string [split $line " "]
- if {$indentfirstline == 0} {
- set newline ""
- set maxlen [expr {$maxlen - [string length $indent]}]
- } else {
- set newline $indent
- }
- append newline [lindex $string 0]
- set joiner " "
- set first 1
- foreach word [lrange $string 1 end] {
- if {[string length $newline]+[string length $word] >= $maxlen} {
- lappend lines $newline
- set newline $indent
- set joiner ""
- # If indentfirstline is set to 0, reset maxlen to its
- # original length after appending the first line to lines.
- if {$first == 1 && $indentfirstline == 0} {
- set maxlen [expr {$maxlen + [string length $indent]}]
- }
- set first 0
- }
- append newline $joiner $word
- set joiner " "
- }
- lappend lines $newline
- return [join $lines "\n"]
-}
-
-##
-# Wraps a line at a specified width with a label in front
-#
-# @see wrap
-#
-# @param label label for output
-# @param string input string
-# @param maxlen text width (0 defaults to current terminal width)
-# @return wrapped string
-proc wraplabel {label string maxlen {indent ""}} {
- append label ": [string repeat " " [expr {[string length $indent] - [string length "$label: "]}]]"
- return "$label[wrap $string $maxlen $indent 0]"
-}
-
-proc unobscure_maintainers { list } {
- set result {}
- foreach m $list {
- if {[string first "@" $m] < 0} {
- if {[string first ":" $m] >= 0} {
- set m [regsub -- "(.*):(.*)" $m "\\2@\\1"]
- } else {
- set m "$m at macports.org"
- }
- }
- lappend result $m
- }
- return $result
-}
-
-
-##########################################
-# Port selection
-##########################################
-proc unique_results_to_portlist {infos} {
- set result {}
- array unset unique
- foreach {name info} $infos {
- array unset portinfo
- array set portinfo $info
-
- set portentry [entry_for_portlist [list url $portinfo(porturl) name $name]]
-
- array unset entry
- array set entry $portentry
-
- if {[info exists unique($entry(fullname))]} continue
- set unique($entry(fullname)) 1
-
- lappend result $portentry
- }
- return $result
-}
-
-
-proc get_matching_ports {pattern {casesensitive no} {matchstyle glob} {field name}} {
- if {[catch {set res [mportsearch $pattern $casesensitive $matchstyle $field]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "search for portname $pattern failed: $result"
- }
- set results [unique_results_to_portlist $res]
-
- # Return the list of all ports, sorted
- return [portlist_sort $results]
-}
-
-
-proc get_all_ports {} {
- global all_ports_cache
-
- if {![info exists all_ports_cache]} {
- if {[catch {set res [mportlistall]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "listing all ports failed: $result"
- }
- set results [unique_results_to_portlist $res]
- set all_ports_cache [portlist_sort $results]
- }
- return $all_ports_cache
-}
-
-
-proc get_current_ports {} {
- # This is just a synonym for get_current_port that
- # works with the regex in element
- return [get_current_port]
-}
-
-
-proc get_current_port {} {
- set url file://.
- set portname [url_to_portname $url]
- if {$portname eq ""} {
- ui_msg "To use the current port, you must be in a port's directory."
- return [list]
- }
-
- set results {}
- add_to_portlist results [list url $url name $portname]
- return $results
-}
-
-
-proc get_installed_ports { {ignore_active yes} {active yes} } {
- set ilist {}
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "port installed failed: $result"
- }
- }
-
- set results {}
- foreach i $ilist {
- set iname [lindex $i 0]
- set iversion [lindex $i 1]
- set irevision [lindex $i 2]
- set ivariants [split_variants [lindex $i 3]]
- set iactive [lindex $i 4]
-
- if { ${ignore_active} == "yes" || (${active} == "yes") == (${iactive} != 0) } {
- add_to_portlist results [list name $iname version "${iversion}_${irevision}" variants $ivariants]
- }
- }
-
- # Return the list of ports, sorted
- return [portlist_sort $results]
-}
-
-
-proc get_uninstalled_ports {} {
- # Return all - installed
- set all [get_all_ports]
- set installed [get_installed_ports]
- return [opComplement $all $installed]
-}
-
-
-proc get_active_ports {} {
- return [get_installed_ports no yes]
-}
-
-
-proc get_inactive_ports {} {
- return [get_installed_ports no no]
-}
-
-proc get_actinact_ports {} {
- set inactive_ports [get_inactive_ports]
- set active_ports [get_active_ports]
- set results {}
-
- foreach port $inactive_ports {
- array set portspec $port
- set portname $portspec(name)
- lappend inact($portname) $port
- }
-
- foreach port $active_ports {
- array set portspec $port
- set portname $portspec(name)
-
- if {[info exists inact($portname)]} {
- if {![info exists added_inact($portname)]} {
- foreach inact_spec $inact($portname) {
- lappend results $inact_spec
- }
- set added_inact($portname) 1
- }
- lappend results $port
- }
- }
- return $results
-}
-
-
-proc get_outdated_ports {} {
- # Get the list of installed ports
- set ilist {}
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "port installed failed: $result"
- }
- }
-
- # Now process the list, keeping only those ports that are outdated
- set results {}
- if { [llength $ilist] > 0 } {
- foreach i $ilist {
-
- # Get information about the installed port
- set portname [lindex $i 0]
- set installed_version [lindex $i 1]
- set installed_revision [lindex $i 2]
- set installed_compound "${installed_version}_${installed_revision}"
- set installed_variants [lindex $i 3]
-
- set is_active [lindex $i 4]
- if {$is_active == 0} continue
-
- set installed_epoch [lindex $i 5]
-
- # Get info about the port from the index
- if {[catch {set res [mportlookup $portname]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "lookup of portname $portname failed: $result"
- }
- if {[llength $res] < 2} {
- if {[macports::ui_isset ports_debug]} {
- puts stderr "$portname ($installed_compound is installed; the port was not found in the port index)"
- }
- continue
- }
- array unset portinfo
- array set portinfo [lindex $res 1]
-
- # Get information about latest available version and revision
- set latest_version $portinfo(version)
- set latest_revision 0
- if {[info exists portinfo(revision)] && $portinfo(revision) > 0} {
- set latest_revision $portinfo(revision)
- }
- set latest_compound "${latest_version}_${latest_revision}"
- set latest_epoch 0
- if {[info exists portinfo(epoch)]} {
- set latest_epoch $portinfo(epoch)
- }
-
- # Compare versions, first checking epoch, then version, then revision
- set comp_result 0
- if {$installed_version != $latest_version} {
- set comp_result [expr {$installed_epoch - $latest_epoch}]
- if { $comp_result == 0 } {
- set comp_result [vercmp $installed_version $latest_version]
- }
- }
- if { $comp_result == 0 } {
- set comp_result [expr {$installed_revision - $latest_revision}]
- }
- if {$comp_result == 0} {
- set regref [registry::open_entry $portname $installed_version $installed_revision $installed_variants $installed_epoch]
- set os_platform_installed [registry::property_retrieve $regref os_platform]
- set os_major_installed [registry::property_retrieve $regref os_major]
- if {$os_platform_installed ne "" && $os_platform_installed != 0
- && $os_major_installed ne "" && $os_major_installed != 0
- && ($os_platform_installed != ${macports::os_platform} || $os_major_installed != ${macports::os_major})} {
- set comp_result -1
- }
- }
-
- # Add outdated ports to our results list
- if { $comp_result < 0 } {
- add_to_portlist results [list name $portname version $installed_compound variants [split_variants $installed_variants]]
- }
- }
- }
-
- return [portlist_sort $results]
-}
-
-
-proc get_obsolete_ports {} {
- set ilist [get_installed_ports]
- set results {}
-
- foreach i $ilist {
- array set port $i
-
- if {[catch {mportlookup $port(name)} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
-
- if {[llength $result] < 2} {
- lappend results $i
- }
- }
-
- # Return the list of ports, already sorted
- return [portlist_sort $results]
-}
-
-# return ports that have registry property $propname set to $propval
-proc get_ports_with_prop {propname propval} {
- set ilist {}
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "port installed failed: $result"
- }
- }
-
- set results {}
- foreach i $ilist {
- set iname [lindex $i 0]
- set iversion [lindex $i 1]
- set irevision [lindex $i 2]
- set ivariants [lindex $i 3]
- set iepoch [lindex $i 5]
- set regref [registry::open_entry $iname $iversion $irevision $ivariants $iepoch]
- if {[registry::property_retrieve $regref $propname] == $propval} {
- add_to_portlist results [list name $iname version "${iversion}_${irevision}" variants [split_variants $ivariants]]
- }
- }
-
- # Return the list of ports, sorted
- return [portlist_sort $results]
-}
-
-proc get_requested_ports {} {
- return [get_ports_with_prop requested 1]
-}
-
-proc get_unrequested_ports {} {
- return [get_ports_with_prop requested 0]
-}
-
-proc get_leaves_ports {} {
- set ilist {}
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "port installed failed: $result"
- }
- }
- registry::open_dep_map
- set results {}
- foreach i $ilist {
- set iname [lindex $i 0]
- if {[registry::list_dependents $iname] eq ""} {
- add_to_portlist results [list name $iname version "[lindex $i 1]_[lindex $i 2]" variants [split_variants [lindex $i 3]]]
- }
- }
- return [portlist_sort [opIntersection $results [get_unrequested_ports]]]
-}
-
-proc get_dependent_ports {portname recursive} {
- registry::open_dep_map
- set deplist [registry::list_dependents $portname]
- # could return specific versions here using registry2.0 features
- set results {}
- foreach dep $deplist {
- add_to_portlist results [list name [lindex $dep 2]]
- }
-
- # actually do this iteratively to avoid hitting Tcl's recursion limit
- if {$recursive} {
- while 1 {
- set rportlist {}
- set newlist {}
- foreach dep $deplist {
- set depname [lindex $dep 2]
- if {![info exists seen($depname)]} {
- set seen($depname) 1
- set rdeplist [registry::list_dependents $depname]
- foreach rdep $rdeplist {
- lappend newlist $rdep
- add_to_portlist rportlist [list name [lindex $rdep 2]]
- }
- }
- }
- if {[llength $rportlist] > 0} {
- set results [opUnion $results $rportlist]
- set deplist $newlist
- } else {
- break
- }
- }
- }
-
- return [portlist_sort $results]
-}
-
-
-proc get_dep_ports {portname recursive} {
- global global_variations
-
- # look up portname
- if {[catch {mportlookup $portname} result]} {
- ui_debug "$::errorInfo"
- return -code error "lookup of portname $portname failed: $result"
- }
- if {[llength $result] < 2} {
- return -code error "Port $portname not found"
- }
- array unset portinfo
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
-
- # open portfile
- if {[catch {set mport [mportopen $porturl [list subport $portinfo(name)] [array get global_variations]]} result]} {
- ui_debug "$::errorInfo"
- return -code error "Unable to open port: $result"
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
-
- # gather its deps
- set results {}
- set deptypes {depends_fetch depends_extract depends_build depends_lib depends_run}
-
- set deplist {}
- foreach type $deptypes {
- if {[info exists portinfo($type)]} {
- foreach dep $portinfo($type) {
- add_to_portlist results [list name [lindex [split $dep :] end]]
- lappend deplist $dep
- }
- }
- }
-
- # actually do this iteratively to avoid hitting Tcl's recursion limit
- if {$recursive} {
- while 1 {
- set rportlist {}
- set newlist {}
- foreach dep $deplist {
- set depname [lindex [split $dep :] end]
- if {![info exists seen($depname)]} {
- set seen($depname) 1
-
- # look up the dep
- if {[catch {mportlookup $depname} result]} {
- ui_debug "$::errorInfo"
- return -code error "lookup of portname $depname failed: $result"
- }
- if {[llength $result] < 2} {
- ui_error "Port $depname not found"
- continue
- }
- array unset portinfo
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
-
- # open its portfile
- if {[catch {set mport [mportopen $porturl [list subport $portinfo(name)] [array get global_variations]]} result]} {
- ui_debug "$::errorInfo"
- ui_error "Unable to open port: $result"
- continue
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
-
- # collect its deps
- set rdeplist {}
- foreach type $deptypes {
- if {[info exists portinfo($type)]} {
- foreach rdep $portinfo($type) {
- add_to_portlist results [list name [lindex [split $rdep :] end]]
- lappend rdeplist $rdep
- }
- }
- }
-
- # add them to the lists
- foreach rdep $rdeplist {
- lappend newlist $rdep
- add_to_portlist rportlist [list name [lindex [split $rdep :] end]]
- }
- }
- }
- if {[llength $rportlist] > 0} {
- set results [opUnion $results $rportlist]
- set deplist $newlist
- } else {
- break
- }
- }
- }
-
- return [portlist_sort $results]
-}
-
-proc get_subports {portname} {
- global global_variations
-
- # look up portname
- if {[catch {mportlookup $portname} result]} {
- ui_debug "$::errorInfo"
- return -code error "lookup of portname $portname failed: $result"
- }
- if {[llength $result] < 2} {
- return -code error "Port $portname not found"
- }
- array unset portinfo
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
-
- # open portfile
- if {[catch {set mport [mportopen $porturl [list subport $portinfo(name)] [array get global_variations]]} result]} {
- ui_debug "$::errorInfo"
- return -code error "Unable to open port: $result"
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
-
- # gather its subports
- set results {}
-
- if {[info exists portinfo(subports)]} {
- foreach subport $portinfo(subports) {
- add_to_portlist results [list name $subport]
- }
- }
-
- return [portlist_sort $results]
-}
-
-
-##########################################
-# Port expressions
-##########################################
-proc portExpr { resname } {
- upvar $resname reslist
- set result [seqExpr reslist]
- return $result
-}
-
-
-proc seqExpr { resname } {
- upvar $resname reslist
-
- # Evaluate a sequence of expressions a b c...
- # These act the same as a or b or c
-
- set result 1
- while {$result} {
- switch -- [lookahead] {
- ; -
- ) -
- _EOF_ { break }
- }
-
- set blist {}
- set result [orExpr blist]
- if {$result} {
- # Calculate the union of result and b
- set reslist [opUnion $reslist $blist]
- }
- }
-
- return $result
-}
-
-
-proc orExpr { resname } {
- upvar $resname reslist
-
- set a [andExpr reslist]
- while ($a) {
- switch -- [lookahead] {
- or {
- advance
- set blist {}
- if {![andExpr blist]} {
- return 0
- }
-
- # Calculate a union b
- set reslist [opUnion $reslist $blist]
- }
- default {
- return $a
- }
- }
- }
-
- return $a
-}
-
-
-proc andExpr { resname } {
- upvar $resname reslist
-
- set a [unaryExpr reslist]
- while {$a} {
- switch -- [lookahead] {
- and {
- advance
-
- set blist {}
- set b [unaryExpr blist]
- if {!$b} {
- return 0
- }
-
- # Calculate a intersect b
- set reslist [opIntersection $reslist $blist]
- }
- default {
- return $a
- }
- }
- }
-
- return $a
-}
-
-
-proc unaryExpr { resname } {
- upvar $resname reslist
- set result 0
-
- switch -- [lookahead] {
- ! -
- not {
- advance
- set blist {}
- set result [unaryExpr blist]
- if {$result} {
- set all [get_all_ports]
- set reslist [opComplement $all $blist]
- }
- }
- default {
- set result [element reslist]
- }
- }
-
- return $result
-}
-
-
-proc element { resname } {
- upvar $resname reslist
- set el 0
-
- set url ""
- set name ""
- set version ""
- array unset requested_variants
- array unset options
-
- set token [lookahead]
- switch -regex -- $token {
- ^\\)$ -
- ^\; -
- ^_EOF_$ { # End of expression/cmd/file
- }
-
- ^\\($ { # Parenthesized Expression
- advance
- set el [portExpr reslist]
- if {!$el || ![match ")"]} {
- set el 0
- }
- }
-
- ^all(@.*)?$ -
- ^installed(@.*)?$ -
- ^uninstalled(@.*)?$ -
- ^active(@.*)?$ -
- ^inactive(@.*)?$ -
- ^actinact(@.*)?$ -
- ^leaves(@.*)?$ -
- ^outdated(@.*)?$ -
- ^obsolete(@.*)?$ -
- ^requested(@.*)?$ -
- ^unrequested(@.*)?$ -
- ^current(@.*)?$ {
- # A simple pseudo-port name
- advance
-
- # Break off the version component, if there is one
- regexp {^(\w+)(@.*)?} $token matchvar name remainder
-
- add_multiple_ports reslist [get_${name}_ports] $remainder
-
- set el 1
- }
-
- ^variants: -
- ^variant: -
- ^description: -
- ^portdir: -
- ^homepage: -
- ^epoch: -
- ^platforms: -
- ^platform: -
- ^name: -
- ^long_description: -
- ^maintainers: -
- ^maintainer: -
- ^categories: -
- ^category: -
- ^version: -
- ^depends_lib: -
- ^depends_build: -
- ^depends_run: -
- ^depends_extract: -
- ^depends_fetch: -
- ^replaced_by: -
- ^revision: -
- ^subport: -
- ^subports: -
- ^license: { # Handle special port selectors
- advance
-
- # Break up the token, because older Tcl switch doesn't support -matchvar
- regexp {^(\w+):(.*)} $token matchvar field pat
-
- # Remap friendly names to actual names
- set field [map_friendly_field_names $field]
-
- add_multiple_ports reslist [get_matching_ports $pat no regexp $field]
- set el 1
- }
-
- ^depends: { # A port selector shorthand for depends_{lib,build,run,fetch,extract}
- advance
-
- # Break up the token, because older Tcl switch doesn't support -matchvar
- regexp {^(\w+):(.*)} $token matchvar field pat
-
- add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_lib"]
- add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_build"]
- add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_run"]
- add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_extract"]
- add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_fetch"]
-
- set el 1
- }
-
- ^dependentof: -
- ^rdependentof: {
- advance
-
- # Break up the token, because older Tcl switch doesn't support -matchvar
- regexp {^(\w+):(.*)} $token matchvar selector portname
-
- set recursive [string equal $selector "rdependentof"]
- add_multiple_ports reslist [get_dependent_ports $portname $recursive]
-
- set el 1
- }
-
- ^depof: -
- ^rdepof: {
- advance
-
- # Break up the token, because older Tcl switch doesn't support -matchvar
- regexp {^(\w+):(.*)} $token matchvar selector portname
-
- set recursive [string equal $selector "rdepof"]
- add_multiple_ports reslist [get_dep_ports $portname $recursive]
-
- set el 1
- }
-
- ^subportof: {
- advance
-
- # Break up the token, because older Tcl switch doesn't support -matchvar
- regexp {^(\w+):(.*)} $token matchvar selector portname
-
- add_multiple_ports reslist [get_subports $portname]
-
- set el 1
- }
-
- [][?*] { # Handle portname glob patterns
- advance; add_multiple_ports reslist [get_matching_ports $token no glob]
- set el 1
- }
-
- ^\\w+:.+ { # Handle a url by trying to open it as a port and mapping the name
- advance
- set name [url_to_portname $token]
- if {$name ne ""} {
- parsePortSpec version requested_variants options
- add_to_portlist reslist [list url $token \
- name $name \
- version $version \
- requested_variants [array get requested_variants] \
- variants [array get requested_variants] \
- options [array get options]]
- set el 1
- } else {
- ui_error "Can't open URL '$token' as a port"
- set el 0
- }
- }
-
- default { # Treat anything else as a portspec (portname, version, variants, options
- # or some combination thereof).
- parseFullPortSpec url name version requested_variants options
- add_to_portlist reslist [list url $url \
- name $name \
- version $version \
- requested_variants [array get requested_variants] \
- variants [array get requested_variants] \
- options [array get options]]
- set el 1
- }
- }
-
- return $el
-}
-
-
-proc add_multiple_ports { resname ports {remainder ""} } {
- upvar $resname reslist
-
- set version ""
- array unset variants
- array unset options
- parsePortSpec version variants options $remainder
-
- array unset overrides
- if {$version ne ""} { set overrides(version) $version }
- if {[array size variants]} {
- # we always record the requested variants separately,
- # but requested ones always override existing ones
- set overrides(requested_variants) [array get variants]
- set overrides(variants) [array get variants]
- }
- if {[array size options]} { set overrides(options) [array get options] }
-
- add_ports_to_portlist reslist $ports [array get overrides]
-}
-
-
-proc unique_entries { entries } {
- # Form the list of all the unique elements in the list a,
- # considering only the port fullname, and taking the first
- # found element first
- set result {}
- array unset unique
- foreach item $entries {
- array set port $item
- if {[info exists unique($port(fullname))]} continue
- set unique($port(fullname)) 1
- lappend result $item
- }
- return $result
-}
-
-
-proc opUnion { a b } {
- # Return the unique elements in the combined two lists
- return [unique_entries [concat $a $b]]
-}
-
-
-proc opIntersection { a b } {
- set result {}
-
- # Rules we follow in performing the intersection of two port lists:
- #
- # a/, a/ ==> a/
- # a/, b/ ==>
- # a/, a/1.0 ==> a/1.0
- # a/1.0, a/ ==> a/1.0
- # a/1.0, a/2.0 ==>
- #
- # If there's an exact match, we take it.
- # If there's a match between simple and discriminated, we take the later.
-
- # First create a list of the fully discriminated names in b
- array unset bfull
- set i 0
- foreach bitem [unique_entries $b] {
- array set port $bitem
- set bfull($port(fullname)) $i
- incr i
- }
-
- # Walk through each item in a, matching against b
- foreach aitem [unique_entries $a] {
- array set port $aitem
-
- # Quote the fullname and portname to avoid special characters messing up the regexp
- set safefullname [regex_pat_sanitize $port(fullname)]
-
- set simpleform [expr { "$port(name)/" == $port(fullname) }]
- if {$simpleform} {
- set pat "^${safefullname}"
- } else {
- set safename [regex_pat_sanitize $port(name)]
- set pat "^${safefullname}$|^${safename}/$"
- }
-
- set matches [array names bfull -regexp $pat]
- foreach match $matches {
- if {$simpleform} {
- set i $bfull($match)
- lappend result [lindex $b $i]
- } else {
- lappend result $aitem
- }
- }
- }
-
- return $result
-}
-
-
-proc opComplement { a b } {
- set result {}
-
- # Return all elements of a not matching elements in b
-
- # First create a list of the fully discriminated names in b
- array unset bfull
- set i 0
- foreach bitem $b {
- array set port $bitem
- set bfull($port(fullname)) $i
- incr i
- }
-
- # Walk through each item in a, taking all those items that don't match b
- foreach aitem $a {
- array set port $aitem
-
- # Quote the fullname and portname to avoid special characters messing up the regexp
- set safefullname [regex_pat_sanitize $port(fullname)]
-
- set simpleform [expr { "$port(name)/" == $port(fullname) }]
- if {$simpleform} {
- set pat "^${safefullname}"
- } else {
- set safename [regex_pat_sanitize $port(name)]
- set pat "^${safefullname}$|^${safename}/$"
- }
-
- set matches [array names bfull -regexp $pat]
-
- # We copy this element to result only if it didn't match against b
- if {![llength $matches]} {
- lappend result $aitem
- }
- }
-
- return $result
-}
-
-
-proc parseFullPortSpec { urlname namename vername varname optname } {
- upvar $urlname porturl
- upvar $namename portname
- upvar $vername portversion
- upvar $varname portvariants
- upvar $optname portoptions
-
- set portname ""
- set portversion ""
- array unset portvariants
- array unset portoptions
-
- if { [moreargs] } {
- # Look first for a potential portname
- #
- # We need to allow a wide variety of tokens here, because of actions like "provides"
- # so we take a rather lenient view of what a "portname" is. We allow
- # anything that doesn't look like either a version, a variant, or an option
- set token [lookahead]
-
- set remainder ""
- if {|[[:alpha:]_]+[\w\.]*=)} $token match]} {
- advance
- regexp {^([^@]+)(@.*)?} $token match portname remainder
-
- # If the portname contains a /, then try to use it as a URL
- if {[string match "*/*" $portname]} {
- set url "file://$portname"
- set name [url_to_portname $url 1]
- if { $name ne "" } {
- # We mapped the url to valid port
- set porturl $url
- set portname $name
- # Continue to parse rest of portspec....
- } else {
- # We didn't map the url to a port; treat it
- # as a raw string for something like port contents
- # or cd
- set porturl ""
- # Since this isn't a port, we don't try to parse
- # any remaining portspec....
- return
- }
- }
- }
-
- # Now parse the rest of the spec
- parsePortSpec portversion portvariants portoptions $remainder
- }
-}
-
-# check if the install prefix is writable
-# should be called by actions that will modify it
-proc prefix_unwritable {} {
- global macports::portdbpath
- if {[file writable $portdbpath]} {
- return 0
- } else {
- ui_error "Insufficient privileges to write to MacPorts install prefix."
- return 1
- }
-}
-
-
-proc parsePortSpec { vername varname optname {remainder ""} } {
- upvar $vername portversion
- upvar $varname portvariants
- upvar $optname portoptions
-
- global global_options
-
- set portversion ""
- array unset portoptions
- array set portoptions [array get global_options]
- array unset portvariants
-
- # Parse port version/variants/options
- set opt $remainder
- set adv 0
- set consumed 0
- for {set firstTime 1} {$opt ne "" || [moreargs]} {set firstTime 0} {
-
- # Refresh opt as needed
- if {$opt eq ""} {
- if {$adv} advance
- set opt [lookahead]
- set adv 1
- set consumed 0
- }
-
- # Version must be first, if it's there at all
- if {$firstTime && [string match {@*} $opt]} {
- # Parse the version
-
- # Strip the @
- set opt [string range $opt 1 end]
-
- # Handle the version
- set sepPos [string first "/" $opt]
- if {$sepPos >= 0} {
- # Version terminated by "/" to disambiguate -variant from part of version
- set portversion [string range $opt 0 [expr {$sepPos - 1}]]
- set opt [string range $opt [expr {$sepPos + 1}] end]
- } else {
- # Version terminated by "+", or else is complete
- set sepPos [string first "+" $opt]
- if {$sepPos >= 0} {
- # Version terminated by "+"
- set portversion [string range $opt 0 [expr {$sepPos - 1}]]
- set opt [string range $opt $sepPos end]
- } else {
- # Unterminated version
- set portversion $opt
- set opt ""
- }
- }
- set consumed 1
- } else {
- # Parse all other options
-
- # Look first for a variable setting: VARNAME=VALUE
- if {[regexp {^([[:alpha:]_]+[\w\.]*)=(.*)} $opt match key val] == 1} {
- # It's a variable setting
- set portoptions($key) "\"$val\""
- set opt ""
- set consumed 1
- } elseif {[regexp {^([-+])([[:alpha:]_]+[\w\.]*)} $opt match sign variant] == 1} {
- # It's a variant
- set portvariants($variant) $sign
- set opt [string range $opt [expr {[string length $variant] + 1}] end]
- set consumed 1
- } else {
- # Not an option we recognize, so break from port option processing
- if { $consumed && $adv } advance
- break
- }
- }
- }
-}
-
-
-##########################################
-# Action Handlers
-##########################################
-
-proc action_get_usage { action } {
- global action_array cmd_opts_array
-
- if {[info exists action_array($action)]} {
- set cmds ""
- if {[info exists cmd_opts_array($action)]} {
- foreach opt $cmd_opts_array($action) {
- if {[llength $opt] == 1} {
- set name $opt
- set optc 0
- } else {
- set name [lindex $opt 0]
- set optc [lindex $opt 1]
- }
-
- append cmds " --$name"
-
- for {set i 1} {$i <= $optc} {incr i} {
- append cmds " <arg$i>"
- }
- }
- }
- set args ""
- set needed [action_needs_portlist $action]
- if {[ACTION_ARGS_STRINGS] == $needed} {
- set args " <arguments>"
- } elseif {[ACTION_ARGS_STRINGS] == $needed} {
- set args " <portlist>"
- }
-
- set ret "Usage: "
- set len [string length $action]
- append ret [wrap "$action$cmds$args" 0 [string repeat " " [expr {8 + $len}]] 0]
- append ret "\n"
-
- return $ret
- }
-
- return -1
-}
-
-proc action_usage { action portlist opts } {
- if {[llength $portlist] == 0} {
- print_usage
- return 0
- }
-
- foreach topic $portlist {
- set usage [action_get_usage $topic]
- if {$usage != -1} {
- puts -nonewline stderr $usage
- } else {
- ui_error "No usage for topic $topic"
- return 1
- }
- }
- return 0
-}
-
-
-proc action_help { action portlist opts } {
- set helpfile "$macports::prefix/var/macports/port-help.tcl"
-
- if {[llength $portlist] == 0} {
- print_help
- return 0
- }
-
- if {[file exists $helpfile]} {
- if {[catch {source $helpfile} err]} {
- puts stderr "Error reading helpfile $helpfile: $err"
- return 1
- }
- } else {
- puts stderr "Unable to open help file $helpfile"
- return 1
- }
-
- foreach topic $portlist {
- if {![info exists porthelp($topic)]} {
- puts stderr "No help for topic $topic"
- return 1
- }
-
- set usage [action_get_usage $topic]
- if {$usage != -1} {
- puts -nonewline stderr $usage
- } else {
- ui_error "No usage for topic $topic"
- return 1
- }
-
- puts stderr $porthelp($topic)
- }
-
- return 0
-}
-
-
-proc action_log { action portlist opts } {
- global global_options
- if {[require_portlist portlist]} {
- return 1
- }
- foreachport $portlist {
- # If we have a url, use that, since it's most specific
- # otherwise try to map the portname to a url
- if {$porturl eq ""} {
- # Verify the portname, getting portinfo to map to a porturl
- if {[catch {mportlookup $portname} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Port $portname not found" 1 status
- }
- array unset portinfo
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
- set portdir $portinfo(portdir)
- set portname $portinfo(name)
- } elseif {$porturl ne "file://."} {
- # Extract the portdir from porturl and use it to search PortIndex.
- # Only the last two elements of the path (porturl) make up the
- # portdir.
- set portdir [file split [macports::getportdir $porturl]]
- set lsize [llength $portdir]
- set portdir \
- [file join [lindex $portdir [expr {$lsize - 2}]] \
- [lindex $portdir [expr {$lsize - 1}]]]
- if {[catch {mportsearch $portdir no exact portdir} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Portdir $portdir not found" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Portdir $portdir not found" 1 status
- }
- array unset portinfo
- set matchindex [lsearch -exact -nocase $result $portname]
- if {$matchindex != -1} {
- array set portinfo [lindex $result [incr matchindex]]
- } else {
- ui_warn "Portdir $portdir doesn't seem to belong to portname $portname"
- array set portinfo [lindex $result 1]
- }
- set portname $portinfo(name)
- }
- set portpath [macports::getportdir $porturl]
- set logfile [file join [macports::getportlogpath $portpath $portname] "main.log"]
- if {[file exists $logfile]} {
- if {[catch {set fp [open $logfile r]} result]} {
- break_softcontinue "Could not open file $logfile: $result" 1 status
- }
- set data [read $fp]
- set data [split $data "\n"]
-
- if {[info exists global_options(ports_log_phase)]} {
- set phase $global_options(ports_log_phase);
- } else {
- set phase "\[a-z\]*"
- }
-
- if {[info exists global_options(ports_log_level)]} {
- set index [lsearch -exact ${macports::ui_priorities} $global_options(ports_log_level)]
- if {$index == -1} {
- set prefix ""
- } else {
- set prefix [join [lrange ${macports::ui_priorities} 0 $index] "|"]
- }
- } else {
- set prefix "\[a-z\]*"
- }
- foreach line $data {
- set exp "^:($prefix|any):($phase|any) (.*)$"
- if {[regexp $exp $line -> lpriority lphase lmsg] == 1} {
- puts "[macports::ui_prefix_default $lpriority]$lmsg"
- }
- }
-
- close $fp
- } else {
- break_softcontinue "Log file for port $portname not found" 1 status
- }
- }
- return 0
-}
-
-
-proc action_info { action portlist opts } {
- global global_variations
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
-
- set separator ""
- foreachport $portlist {
- set index_only 0
- if {[info exists options(ports_info_index)] && $options(ports_info_index)} {
- set index_only 1
- }
- puts -nonewline $separator
- array unset portinfo
- # If we have a url, use that, since it's most specific
- # otherwise try to map the portname to a url
- if {$porturl eq "" || $index_only} {
- # Verify the portname, getting portinfo to map to a porturl
- if {[catch {mportlookup $portname} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Port $portname not found" 1 status
- }
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
- set portdir $portinfo(portdir)
- }
-
- if {!$index_only} {
- # Add any global_variations to the variations
- # specified for the port (so we get e.g. dependencies right)
- array unset merged_variations
- array set merged_variations [array get variations]
- foreach { variation value } [array get global_variations] {
- if { ![info exists merged_variations($variation)] } {
- set merged_variations($variation) $value
- }
- }
- if {![info exists options(subport)]} {
- if {[info exists portinfo(name)]} {
- set options(subport) $portinfo(name)
- } else {
- set options(subport) $portname
- }
- }
-
- if {[catch {set mport [mportopen $porturl [array get options] [array get merged_variations]]} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Unable to open port: $result" 1 status
- }
- unset options(subport)
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
- if {[info exists portdir]} {
- set portinfo(portdir) $portdir
- }
- } elseif {![info exists portinfo]} {
- ui_warn "no PortIndex entry found for $portname"
- continue
- }
- array unset options ports_info_index
-
- # Understand which info items are actually lists
- # (this could be overloaded to provide a generic formatting code to
- # allow us to, say, split off the prefix on libs)
- array set list_map "
- categories 1
- depends_fetch 1
- depends_extract 1
- depends_build 1
- depends_lib 1
- depends_run 1
- maintainers 1
- platforms 1
- variants 1
- conflicts 1
- subports 1
- "
-
- # Label map for pretty printing
- array set pretty_label {
- heading ""
- variants Variants
- depends_fetch "Fetch Dependencies"
- depends_extract "Extract Dependencies"
- depends_build "Build Dependencies"
- depends_run "Runtime Dependencies"
- depends_lib "Library Dependencies"
- description "Brief Description"
- long_description "Description"
- fullname "Full Name: "
- homepage Homepage
- platforms Platforms
- maintainers Maintainers
- license License
- conflicts "Conflicts with"
- replaced_by "Replaced by"
- subports "Sub-ports"
- }
-
- # Wrap-length map for pretty printing
- array set pretty_wrap {
- heading 0
- replaced_by 22
- variants 22
- depends_fetch 22
- depends_extract 22
- depends_build 22
- depends_run 22
- depends_lib 22
- description 22
- long_description 22
- homepage 22
- platforms 22
- license 22
- conflicts 22
- maintainers 22
- subports 22
- }
-
- # Interpret a convenient field abbreviation
- if {[info exists options(ports_info_depends)] && $options(ports_info_depends) eq "yes"} {
- array unset options ports_info_depends
- set options(ports_info_depends_fetch) yes
- set options(ports_info_depends_extract) yes
- set options(ports_info_depends_build) yes
- set options(ports_info_depends_lib) yes
- set options(ports_info_depends_run) yes
- }
-
- # Set up our field separators
- set show_label 1
- set field_sep "\n"
- set subfield_sep ", "
- set pretty_print 0
-
- # For human-readable summary, which is the default with no options
- if {[llength [array get options ports_info_*]] == 0} {
- set pretty_print 1
- } elseif {[info exists options(ports_info_pretty)]} {
- set pretty_print 1
- array unset options ports_info_pretty
- }
-
- # Tune for sort(1)
- if {[info exists options(ports_info_line)]} {
- array unset options ports_info_line
- set noseparator 1
- set show_label 0
- set field_sep "\t"
- set subfield_sep ","
- }
-
- # Figure out whether to show field name
- set quiet [macports::ui_isset ports_quiet]
- if {$quiet} {
- set show_label 0
- }
- # In pretty-print mode we also suppress messages, even though we show
- # most of the labels:
- if {$pretty_print} {
- set quiet 1
- }
-
- # Spin through action options, emitting information for any found
- set fields {}
- set opts_todo [array names options ports_info_*]
- set fields_tried {}
- if {![llength $opts_todo]} {
- set opts_todo {ports_info_heading
- ports_info_replaced_by
- ports_info_subports
- ports_info_variants
- ports_info_skip_line
- ports_info_long_description ports_info_homepage
- ports_info_skip_line ports_info_depends_fetch
- ports_info_depends_extract ports_info_depends_build
- ports_info_depends_lib ports_info_depends_run
- ports_info_conflicts
- ports_info_platforms ports_info_license
- ports_info_maintainers
- }
- }
- foreach { option } $opts_todo {
- set opt [string range $option 11 end]
- # Artificial field name for formatting
- if {$pretty_print && $opt eq "skip_line"} {
- lappend fields ""
- continue
- }
- # Artificial field names to reproduce prettyprinted summary
- if {$opt eq "heading"} {
- set inf "$portinfo(name) @$portinfo(version)"
- set ropt "heading"
- if {[info exists portinfo(revision)] && $portinfo(revision) > 0} {
- append inf "_$portinfo(revision)"
- }
- if {[info exists portinfo(categories)]} {
- append inf " ([join $portinfo(categories) ", "])"
- }
- } elseif {$opt eq "fullname"} {
- set inf "$portinfo(name) @"
- append inf [composite_version $portinfo(version) $portinfo(active_variants)]
- set ropt "fullname"
- } else {
- # Map from friendly name
- set ropt [map_friendly_field_names $opt]
-
- # If there's no such info, move on
- if {![info exists portinfo($ropt)]} {
- set inf ""
- } else {
- set inf [join $portinfo($ropt)]
- }
- }
-
- # Calculate field label
- set label ""
- if {$pretty_print} {
- if {[info exists pretty_label($ropt)]} {
- set label $pretty_label($ropt)
- } else {
- set label $opt
- }
- } elseif {$show_label} {
- set label "$opt: "
- }
-
- # Format the data
- if { $ropt eq "maintainers" } {
- set inf [unobscure_maintainers $inf]
- }
- # ... special formatting for certain fields when prettyprinting
- if {$pretty_print} {
- if {$ropt eq "variants"} {
- # Use the new format for variants iff it exists in
- # PortInfo. This key currently does not exist outside of
- # trunk (1.8.0).
- array unset vinfo
- if {[info exists portinfo(vinfo)]} {
- array set vinfo $portinfo(vinfo)
- }
-
- set pi_vars $inf
- set inf {}
- foreach v [lsort $pi_vars] {
- set varmodifier ""
- if {[info exists variations($v)]} {
- # selected by command line, prefixed with +/-
- set varmodifier $variations($v)
- } elseif {[info exists global_variations($v)]} {
- # selected by variants.conf, prefixed with (+)/(-)
- set varmodifier "($global_variations($v))"
- # Retrieve additional information from the new key.
- } elseif {[info exists vinfo]} {
- array unset variant
- array set variant $vinfo($v)
- if {[info exists variant(is_default)]} {
- set varmodifier "\[$variant(is_default)]"
- }
- }
- lappend inf "$varmodifier$v"
- }
- } elseif {[string match "depend*" $ropt]
- && ![macports::ui_isset ports_verbose]} {
- set pi_deps $inf
- set inf {}
- foreach d $pi_deps {
- lappend inf [lindex [split $d :] end]
- }
- }
- }
- #End of special pretty-print formatting for certain fields
- if {[info exists list_map($ropt)]} {
- set field [join $inf $subfield_sep]
- } else {
- set field $inf
- }
-
- # Assemble the entry
- if {$pretty_print} {
- # The two special fields are considered headings and are
- # emitted immediately, rather than waiting. Also they are not
- # recorded on the list of fields tried
- if {$ropt eq "heading" || $ropt eq "fullname"} {
- puts "$label$field"
- continue
- }
- }
- lappend fields_tried $label
- if {$pretty_print} {
- if {$field eq ""} {
- continue
- }
- if {$label eq ""} {
- set wrap_len 0
- if {[info exists pretty_wrap($ropt)]} {
- set wrap_len $pretty_wrap($ropt)
- }
- lappend fields [wrap $field 0 [string repeat " " $wrap_len]]
- } else {
- set wrap_len [string length $label]
- if {[info exists pretty_wrap($ropt)]} {
- set wrap_len $pretty_wrap($ropt)
- }
- lappend fields [wraplabel $label $field 0 [string repeat " " $wrap_len]]
- }
-
- } else { # Not pretty print
- lappend fields "$label$field"
- }
- }
-
- # Now output all that information:
- if {[llength $fields]} {
- puts [join $fields $field_sep]
- } else {
- if {$pretty_print && [llength $fields_tried]} {
- puts -nonewline "$portinfo(name) has no "
- puts [join $fields_tried ", "]
- }
- }
- if {![info exists noseparator]} {
- set separator "--\n"
- }
- }
-
- return $status
-}
-
-
-proc action_location { action portlist opts } {
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
- foreachport $portlist {
- if { [catch {set ilist [registry_installed $portname [composite_version $portversion [array get variations]]]} result] } {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port location failed: $result" 1 status
- } else {
- # set portname again since the one we were passed may not have had the correct case
- set portname [lindex $ilist 0]
- set version [lindex $ilist 1]
- set revision [lindex $ilist 2]
- set variants [lindex $ilist 3]
- set epoch [lindex $ilist 5]
- }
-
- set ref [registry::open_entry $portname $version $revision $variants $epoch]
- set imagedir [registry::property_retrieve $ref location]
- ui_notice "Port $portname ${version}_${revision}${variants} is installed as an image in:"
- puts $imagedir
- }
-
- return $status
-}
-
-
-proc action_notes { action portlist opts } {
- if {[require_portlist portlist]} {
- return 1
- }
-
- set status 0
- foreachport $portlist {
- array unset portinfo
- if {$porturl eq ""} {
- # Look up the port.
- if {[catch {mportlookup $portname} result]} {
- ui_debug $::errorInfo
- break_softcontinue "The lookup of '$portname' failed: $result" \
- 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "The port '$portname' was not found" 1 status
- }
-
- # Retrieve the port's URL.
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
- }
-
- # Add any global_variations to the variations
- # specified for the port
- array unset merged_variations
- array set merged_variations [array get variations]
- foreach { variation value } [array get global_variations] {
- if { ![info exists merged_variations($variation)] } {
- set merged_variations($variation) $value
- }
- }
- if {![info exists options(subport)]} {
- if {[info exists portinfo(name)]} {
- set options(subport) $portinfo(name)
- } else {
- set options(subport) $portname
- }
- }
-
- # Open the Portfile associated with this port.
- if {[catch {set mport [mportopen $porturl [array get options] \
- [array get merged_variations]]} \
- result]} {
- ui_debug $::errorInfo
- break_softcontinue [concat "The URL '$porturl' could not be" \
- "opened: $result"] 1 status
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
-
- # Return the notes associated with this Portfile.
- if {[info exists portinfo(notes)]} {
- set portnotes $portinfo(notes)
- } else {
- set portnotes {}
- }
-
- # Retrieve the port's name once more to ensure it has the proper case.
- set portname $portinfo(name)
-
- # Display the notes.
- if {$portnotes ne {}} {
- ui_notice "$portname has the following notes:"
- foreach note $portnotes {
- puts [wrap $note 0 " " 1]
- }
- } else {
- puts "$portname has no notes."
- }
- }
- return $status
-}
-
-
-proc action_provides { action portlist opts } {
- # In this case, portname is going to be used for the filename... since
- # that is the first argument we expect... perhaps there is a better way
- # to do this?
- if { ![llength $portlist] } {
- ui_error "Please specify a filename to check which port provides that file."
- return 1
- }
- foreach filename $portlist {
- set file [file normalize $filename]
- if {[file exists $file] || ![catch {file type $file}]} {
- if {![file isdirectory $file] || [file type $file] eq "link"} {
- set port [registry::file_registered $file]
- if { $port != 0 } {
- puts "$file is provided by: $port"
- } else {
- puts "$file is not provided by a MacPorts port."
- }
- } else {
- puts "$file is a directory."
- }
- } else {
- puts "$file does not exist."
- }
- }
- registry::close_file_map
-
- return 0
-}
-
-
-proc action_activate { action portlist opts } {
- set status 0
- if {[require_portlist portlist] || [prefix_unwritable]} {
- return 1
- }
- foreachport $portlist {
- set composite_version [composite_version $portversion [array get variations]]
- if {![info exists options(ports_activate_no-exec)]
- && ![catch {set ilist [registry::installed $portname $composite_version]}]
- && [llength $ilist] == 1} {
-
- set i [lindex $ilist 0]
- set regref [registry::entry open $portname [lindex $i 1] [lindex $i 2] [lindex $i 3] [lindex $i 5]]
- if {[$regref installtype] eq "image" && [registry::run_target $regref activate [array get options]]} {
- continue
- }
- }
- if {![macports::global_option_isset ports_dryrun]} {
- if { [catch {portimage::activate_composite $portname $composite_version [array get options]} result] } {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port activate failed: $result" 1 status
- }
- } else {
- ui_msg "Skipping activate $portname (dry run)"
- }
- }
-
- return $status
-}
-
-
-proc action_deactivate { action portlist opts } {
- set status 0
- if {[require_portlist portlist] || [prefix_unwritable]} {
- return 1
- }
- set portlist [portlist_sortdependents $portlist]
- foreachport $portlist {
- set composite_version [composite_version $portversion [array get variations]]
- if {![info exists options(ports_deactivate_no-exec)]
- && ![catch {set ilist [registry::active $portname]}]} {
-
- set i [lindex $ilist 0]
- set iversion [lindex $i 1]
- set irevision [lindex $i 2]
- set ivariants [lindex $i 3]
- if {$composite_version eq "" || $composite_version == "${iversion}_${irevision}${ivariants}"} {
- set regref [registry::entry open $portname $iversion $irevision $ivariants [lindex $i 5]]
- if {[$regref installtype] eq "image" && [registry::run_target $regref deactivate [array get options]]} {
- continue
- }
- }
- }
- if {![macports::global_option_isset ports_dryrun]} {
- if { [catch {portimage::deactivate_composite $portname $composite_version [array get options]} result] } {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port deactivate failed: $result" 1 status
- }
- } else {
- ui_msg "Skipping deactivate $portname (dry run)"
- }
- }
-
- return $status
-}
-
-
-proc action_select { action portlist opts } {
- ui_debug "action_select \[$portlist] \[$opts]..."
-
- array set opts_array $opts
- set commands [array names opts_array ports_select_*]
- array unset opts_array
-
- # Error out if no group is specified or command is not --summary.
- if {[llength $portlist] < 1 && [string map {ports_select_ ""} [lindex $commands 0]] != "summary"} {
- ui_error "port select \[--list|--set|--show|--summary] \<group> \[<version>]"
- return 1
- }
-
- set group [lindex $portlist 0]
-
- # If no command (--set, --show, --list, --summary) is specified *but*
- # more than one argument is specified, default to the set command.
- if {[llength $commands] < 1 && [llength $portlist] > 1} {
- set command set
- ui_debug [concat "Although no command was specified, more than " \
- "one argument was specified. Defaulting to the " \
- "'set' command..."]
- # If no command (--set, --show, --list) is specified *and* less than two
- # argument are specified, default to the list command.
- } elseif {[llength $commands] < 1} {
- set command list
- ui_debug [concat "No command was specified. Defaulting to the " \
- "'list' command..."]
- # Only allow one command to be specified at a time.
- } elseif {[llength $commands] > 1} {
- ui_error [concat "Multiple commands were specified. Only one " \
- "command may be specified at a time."]
- return 1
- } else {
- set command [string map {ports_select_ ""} [lindex $commands 0]]
- ui_debug "The '$command' command was specified."
- }
-
- switch -- $command {
- list {
- if {[llength $portlist] > 1} {
- ui_warn [concat "The 'list' command does not expect any " \
- "arguments. Extra arguments will be ignored."]
- }
-
- if {[catch {mportselect show $group} selected_version]} {
- global errorInfo
- ui_debug $errorInfo
- ui_warn "Unable to get active selected version: $selected_version"
- }
-
- # On error mportselect returns with the code 'error'.
- if {[catch {mportselect $command $group} versions]} {
- ui_error "The 'list' command failed: $versions"
- return 1
- }
-
- ui_notice "Available versions for $group:"
- foreach v $versions {
- ui_notice -nonewline "\t"
- if {$selected_version == $v} {
- ui_msg "$v (active)"
- } else {
- ui_msg "$v"
- }
- }
- return 0
- }
- set {
- if {[llength $portlist] < 2} {
- ui_error [concat "The 'set' command expects two " \
- "arguments: <group>, <version>"]
- return 1
- } elseif {[llength $portlist] > 2} {
- ui_warn [concat "The 'set' command only expects two " \
- "arguments. Extra arguments will be " \
- "ignored."]
- }
- set version [lindex $portlist 1]
-
- ui_msg -nonewline "Selecting '$version' for '$group' "
- if {[catch {mportselect $command $group $version} result]} {
- ui_msg "failed: $result"
- return 1
- }
- ui_msg "succeeded. '$version' is now active."
- return 0
- }
- show {
- if {[llength $portlist] > 1} {
- ui_warn [concat "The 'show' command does not expect any " \
- "arguments. Extra arguments will be ignored."]
- }
-
- if {[catch {mportselect $command $group} selected_version]} {
- ui_error "The 'show' command failed: $selected_version"
- return 1
- }
- puts [concat "The currently selected version for '$group' is " \
- "'$selected_version'."]
- return 0
- }
- summary {
- if {[llength $portlist] > 0} {
- ui_warn [concat "The 'summary' command does not expect any " \
- "arguments. Extra arguments will be ignored."]
- }
-
- if {[catch {mportselect $command} portgroups]} {
- ui_error "The 'summary' command failed: $portgroups"
- return 1
- }
-
- set w1 4
- set w2 8
- set formatStr "%-*s %-*s %s"
-
- set groups [list]
- foreach pg $portgroups {
- array set groupdesc {}
- set groupdesc(name) [string trim $pg]
-
- if {[catch {mportselect list $pg} versions]} {
- ui_warn "The list of options for the select group $pg could not be obtained: $versions"
- continue
- }
- # remove "none", sort the list, append none at the end
- set noneidx [lsearch -exact $versions "none"]
- set versions [lsort [lreplace $versions $noneidx $noneidx]]
- lappend versions "none"
- set groupdesc(versions) $versions
-
- if {[catch {mportselect show $pg} selected_version]} {
- ui_warn "The currently selected option for the select group $pg could not be obtained: $selected_version"
- continue
- }
- set groupdesc(selected) $selected_version
-
- set w1 [expr {max($w1, [string length $pg])}]
- set w2 [expr {max($w2, [string length $selected_version])}]
-
- lappend groups [array get groupdesc]
- array unset groupdesc
- }
- puts [format $formatStr $w1 "Name" $w2 "Selected" "Options"]
- puts [format $formatStr $w1 "====" $w2 "========" "======="]
- foreach groupdesc $groups {
- array set groupd $groupdesc
- puts [format $formatStr $w1 $groupd(name) $w2 $groupd(selected) [join $groupd(versions) " "]]
- array unset groupd
- }
- return 0
- }
- default {
- ui_error "An unknown command '$command' was specified."
- return 1
- }
- }
-}
-
-
-proc action_selfupdate { action portlist opts } {
- global global_options
- if { [catch {macports::selfupdate [array get global_options] base_updated} result ] } {
- global errorInfo
- ui_debug "$errorInfo"
- ui_error "$result"
- if {![macports::ui_isset ports_verbose]} {
- ui_msg "Please run `port -v selfupdate' for details."
- } else {
- # Let's only print the ticket URL if the user has followed the
- # advice we printed earlier.
- print_tickets_url
- }
- fatal "port selfupdate failed: $result"
- }
-
- if {$base_updated} {
- # exit immediately if in batch/interactive mode
- return -999
- } else {
- return 0
- }
-}
-
-
-proc action_setrequested { action portlist opts } {
- set status 0
- if {[require_portlist portlist] || [prefix_unwritable]} {
- return 1
- }
- # set or unset?
- set val [string equal $action "setrequested"]
- foreachport $portlist {
- set composite_version [composite_version $portversion [array get variations]]
- if {![catch {set ilist [registry::installed $portname $composite_version]} result]} {
- ui_info "Setting requested flag for $portname to $val"
- foreach i $ilist {
- set regref [registry::open_entry $portname [lindex $i 1] [lindex $i 2] [lindex $i 3] [lindex $i 5]]
- registry::property_store $regref requested $val
- }
- } else {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "$result" 1 status
- }
- }
-
- return $status
-}
-
-
-proc action_upgrade { action portlist opts } {
- if {[require_portlist portlist "yes"] || ([prefix_unwritable] && ![macports::global_option_isset ports_dryrun])} {
- return 1
- }
-
- # shared depscache for all ports in the list
- array set depscache {}
- set status 0
- foreachport $portlist {
- if {![info exists depscache(port:$portname)]} {
- set status [macports::upgrade $portname "port:$portname" [array get requested_variations] [array get options] depscache]
- # status 2 means the port was not found in the index,
- # status 3 means the port is not installed
- if {$status != 0 && $status != 2 && $status != 3 && ![macports::ui_isset ports_processall]} {
- break
- }
- }
- }
-
- if {$status != 0 && $status != 2 && $status != 3} {
- print_tickets_url
- } elseif {$status == 0} {
- array set options $opts
- if {![info exists options(ports_upgrade_no-rev-upgrade)] && ${macports::revupgrade_autorun} && ![macports::global_option_isset ports_dryrun]} {
- set status [action_revupgrade $action $portlist $opts]
- }
- }
-
- return $status
-}
-
-proc action_doctor { action portlist opts } {
-<<<<<<< HEAD
- macports::doctor_main
-=======
- if {[prefix_unwritable]} {
- return 1
- }
- macports::doctor_main $opts
->>>>>>> svn
- return 0
-}
-
-proc action_reclaim { action portlist opts } {
-<<<<<<< HEAD
-=======
- if {[prefix_unwritable]} {
- return 1
- }
->>>>>>> svn
- macports::reclaim_main
- return 0
-}
-
-proc action_revupgrade { action portlist opts } {
- set status [macports::revupgrade $opts]
- if {$status != 0} {
- print_tickets_url
- }
- return $status
-}
-
-
-proc action_version { action portlist opts } {
- if {![macports::ui_isset ports_quiet]} {
- puts -nonewline "Version: "
- }
- puts [macports::version]
- return 0
-}
-
-
-proc action_platform { action portlist opts } {
- if {![macports::ui_isset ports_quiet]} {
- puts -nonewline "Platform: "
- }
- puts "${macports::os_platform} ${macports::os_major} ${macports::os_arch}"
- return 0
-}
-
-
-proc action_dependents { action portlist opts } {
- if {[require_portlist portlist]} {
- return 1
- }
- set ilist {}
-
- registry::open_dep_map
-
- set status 0
- foreachport $portlist {
- set composite_version [composite_version $portversion [array get variations]]
- if { [catch {set ilist [registry::installed $portname $composite_version]} result] } {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "$result" 1 status
- } else {
- # choose the active version if there is one
- set index 0
- foreach i $ilist {
- if {[lindex $i 4]} {
- set found 1
- break
- }
- incr index
- }
- if {![info exists found]} {
- set index 0
- }
- # set portname again since the one we were passed may not have had the correct case
- set portname [lindex $ilist $index 0]
- set iversion [lindex $ilist $index 1]
- set irevision [lindex $ilist $index 2]
- set ivariants [lindex $ilist $index 3]
- }
-
- set deplist [registry::list_dependents $portname $iversion $irevision $ivariants]
- if { [llength $deplist] > 0 } {
- if {$action eq "rdependents"} {
- set toplist $deplist
- while 1 {
- set newlist {}
- foreach dep $deplist {
- set depname [lindex $dep 2]
- if {![info exists seen($depname)]} {
- set seen($depname) 1
- set rdeplist [registry::list_dependents $depname]
- foreach rdep $rdeplist {
- lappend newlist $rdep
- }
- set dependentsof($depname) $rdeplist
- }
- }
- if {[llength $newlist] > 0} {
- set deplist $newlist
- } else {
- break
- }
- }
- set portstack [list $toplist]
- set pos_stack [list 0]
- array unset seen
- ui_notice "The following ports are dependent on ${portname}:"
- while 1 {
- set cur_portlist [lindex $portstack end]
- set cur_pos [lindex $pos_stack end]
- if {$cur_pos >= [llength $cur_portlist]} {
- set portstack [lreplace $portstack end end]
- set pos_stack [lreplace $pos_stack end end]
- if {[llength $portstack] <= 0} {
- break
- } else {
- continue
- }
- }
- set cur_port [lindex $cur_portlist $cur_pos]
- set cur_portname [lindex $cur_port 2]
- set spaces [string repeat " " [expr {[llength $pos_stack] * 2}]]
- if {![info exists seen($cur_portname)] || ([info exists options(ports_rdependents_full)] && [string is true -strict $options(ports_rdependents_full)])} {
- puts "${spaces}${cur_portname}"
- set seen($cur_portname) 1
- incr cur_pos
- set pos_stack [lreplace $pos_stack end end $cur_pos]
- if {[info exists dependentsof($cur_portname)]} {
- lappend portstack $dependentsof($cur_portname)
- lappend pos_stack 0
- }
- continue
- }
- incr cur_pos
- set pos_stack [lreplace $pos_stack end end $cur_pos]
- }
- } else {
- foreach dep $deplist {
- set depport [lindex $dep 2]
- if {[macports::ui_isset ports_quiet]} {
- ui_msg "$depport"
- } elseif {![macports::ui_isset ports_verbose]} {
- ui_msg "$depport depends on $portname"
- } else {
- ui_msg "$depport depends on $portname (by [lindex $dep 1]:)"
- }
- }
- }
- } else {
- ui_notice "$portname has no dependents."
- }
- }
- return $status
-}
-
-
-proc action_deps { action portlist opts } {
- global global_variations
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
- set separator ""
-
- foreachport $portlist {
- if {[info exists options(ports_${action}_no-build)] && [string is true -strict $options(ports_${action}_no-build)]} {
- set deptypes {depends_lib depends_run}
- } else {
- set deptypes {depends_fetch depends_extract depends_build depends_lib depends_run}
- }
-
- array unset portinfo
- # If we have a url, use that, since it's most specific
- # otherwise try to map the portname to a url
- if {$porturl eq ""} {
- # Verify the portname, getting portinfo to map to a porturl
- if {[catch {mportlookup $portname} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Port $portname not found" 1 status
- }
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
- } elseif {$porturl ne "file://."} {
- # Extract the portdir from porturl and use it to search PortIndex.
- # Only the last two elements of the path (porturl) make up the
- # portdir.
- set portdir [file split [macports::getportdir $porturl]]
- set lsize [llength $portdir]
- set portdir \
- [file join [lindex $portdir [expr {$lsize - 2}]] \
- [lindex $portdir [expr {$lsize - 1}]]]
- if {[catch {mportsearch $portdir no exact portdir} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Portdir $portdir not found" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Portdir $portdir not found" 1 status
- }
- set matchindex [lsearch -exact -nocase $result $portname]
- if {$matchindex != -1} {
- array set portinfo [lindex $result [incr matchindex]]
- } else {
- ui_warn "Portdir $portdir doesn't seem to belong to portname $portname"
- array set portinfo [lindex $result 1]
- }
- }
-
- if {!([info exists options(ports_${action}_index)] && $options(ports_${action}_index) eq "yes")} {
- # Add any global_variations to the variations
- # specified for the port, so we get dependencies right
- array unset merged_variations
- array set merged_variations [array get variations]
- foreach { variation value } [array get global_variations] {
- if { ![info exists merged_variations($variation)] } {
- set merged_variations($variation) $value
- }
- }
- if {![info exists options(subport)]} {
- if {[info exists portinfo(name)]} {
- set options(subport) $portinfo(name)
- } else {
- set options(subport) $portname
- }
- }
- if {[catch {set mport [mportopen $porturl [array get options] [array get merged_variations]]} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Unable to open port: $result" 1 status
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
- } elseif {![info exists portinfo]} {
- ui_warn "port ${action} --index does not work with the 'current' pseudo-port"
- continue
- }
- set portname $portinfo(name)
-
- set deplist {}
- set deps_output {}
- set ndeps 0
- array set labeldict {depends_fetch Fetch depends_extract Extract depends_build Build depends_lib Library depends_run Runtime}
- # get list of direct deps
- foreach type $deptypes {
- if {[info exists portinfo($type)]} {
- if {$action eq "rdeps" || [macports::ui_isset ports_verbose]} {
- foreach dep $portinfo($type) {
- lappend deplist $dep
- }
- } else {
- foreach dep $portinfo($type) {
- lappend deplist [lindex [split $dep :] end]
- }
- }
- if {$action eq "deps"} {
- set label "$labeldict($type) Dependencies"
- lappend deps_output [wraplabel $label [join $deplist ", "] 0 [string repeat " " 22]]
- incr ndeps [llength $deplist]
- set deplist {}
- }
- }
- }
-
- set version $portinfo(version)
- set revision $portinfo(revision)
- if {[info exists portinfo(canonical_active_variants)]} {
- set variants $portinfo(canonical_active_variants)
- } else {
- set variants {}
- }
-
- puts -nonewline $separator
- if {$action eq "deps"} {
- if {$ndeps == 0} {
- ui_notice "$portname @${version}_${revision}${variants} has no dependencies."
- } else {
- ui_notice "Full Name: $portname @${version}_${revision}${variants}"
- puts [join $deps_output "\n"]
- }
- set separator "--\n"
- continue
- }
-
- set toplist $deplist
- # gather all the deps
- while 1 {
- set newlist {}
- foreach dep $deplist {
- set depname [lindex [split $dep :] end]
- if {![info exists seen($depname)]} {
- set seen($depname) 1
-
- # look up the dep
- if {[catch {mportlookup $depname} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "lookup of portname $depname failed: $result" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Port $depname not found" 1 status
- }
- array unset portinfo
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
- set options(subport) $portinfo(name)
-
- # open the portfile if requested
- if {!([info exists options(ports_${action}_index)] && $options(ports_${action}_index) eq "yes")} {
- if {[catch {set mport [mportopen $porturl [array get options] [array get merged_variations]]} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Unable to open port: $result" 1 status
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
- }
-
- # get list of the dep's deps
- set rdeplist {}
- foreach type $deptypes {
- if {[info exists portinfo($type)]} {
- foreach rdep $portinfo($type) {
- lappend rdeplist $rdep
- lappend newlist $rdep
- }
- }
- }
- set depsof($depname) $rdeplist
- }
- }
- if {[llength $newlist] > 0} {
- set deplist $newlist
- } else {
- break
- }
- }
- set portstack [list $toplist]
- set pos_stack [list 0]
- array unset seen
- if {[llength $toplist] > 0} {
- ui_notice "The following ports are dependencies of $portname @${version}_${revision}${variants}:"
- } else {
- ui_notice "$portname @${version}_${revision}${variants} has no dependencies."
- }
- while 1 {
- set cur_portlist [lindex $portstack end]
- set cur_pos [lindex $pos_stack end]
- if {$cur_pos >= [llength $cur_portlist]} {
- set portstack [lreplace $portstack end end]
- set pos_stack [lreplace $pos_stack end end]
- if {[llength $portstack] <= 0} {
- break
- } else {
- continue
- }
- }
- set cur_port [lindex $cur_portlist $cur_pos]
- set cur_portname [lindex [split $cur_port :] end]
- set spaces [string repeat " " [expr {[llength $pos_stack] * 2}]]
- if {![info exists seen($cur_portname)] || ([info exists options(ports_${action}_full)] && [string is true -strict $options(ports_${action}_full)])} {
- if {[macports::ui_isset ports_verbose]} {
- puts "${spaces}${cur_port}"
- } else {
- puts "${spaces}${cur_portname}"
- }
- set seen($cur_portname) 1
- incr cur_pos
- set pos_stack [lreplace $pos_stack end end $cur_pos]
- if {[info exists depsof($cur_portname)]} {
- lappend portstack $depsof($cur_portname)
- lappend pos_stack 0
- }
- continue
- }
- incr cur_pos
- set pos_stack [lreplace $pos_stack end end $cur_pos]
- }
- set separator "--\n"
- }
- return $status
-}
-
-
-proc action_uninstall { action portlist opts } {
- set status 0
- if {[macports::global_option_isset port_uninstall_old]} {
- # if -u then uninstall all inactive ports
- # (union these to any other ports user has in the port list)
- set portlist [opUnion $portlist [get_inactive_ports]]
- } else {
- # Otherwise the user hopefully supplied a portlist, or we'll default to the existing directory
- if {[require_portlist portlist]} {
- return 1
- }
- }
- if {[prefix_unwritable]} {
- return 1
- }
-
- set portlist [portlist_sortdependents $portlist]
-
- foreachport $portlist {
- if {![registry::entry_exists_for_name $portname]} {
- # if the code path arrives here the port either isn't installed, or
- # it doesn't exist at all. We can't be sure, but we can check the
- # portindex whether a port by that name exists (in which case not
- # uninstalling it is probably no problem). If there is no port by
- # that name, alert the user in case of typos.
- ui_info "$portname is not installed"
- if {[catch {set res [mportlookup $portname]} result] || [llength $res] == 0} {
- ui_warn "no such port: $portname, skipping uninstall"
- }
- continue
- }
- set composite_version [composite_version $portversion [array get variations]]
- if {![info exists options(ports_uninstall_no-exec)]
- && ![catch {set ilist [registry::installed $portname $composite_version]}]
- && [llength $ilist] == 1} {
-
- set i [lindex $ilist 0]
- set iactive [lindex $i 4]
- set regref [registry::entry open $portname [lindex $i 1] [lindex $i 2] [lindex $i 3] [lindex $i 5]]
- if {[registry::run_target $regref uninstall [array get options]]} {
- continue
- }
- }
-
- if { [catch {registry_uninstall::uninstall_composite $portname $composite_version [array get options]} result] } {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port uninstall failed: $result" 1 status
- }
- }
-
- return $status
-}
-
-
-proc action_installed { action portlist opts } {
- global private_options
- set status 0
- set restrictedList 0
- set ilist {}
-
- if { [llength $portlist] || (![info exists private_options(ports_no_args)] || $private_options(ports_no_args) eq "no")} {
- set restrictedList 1
- foreachport $portlist {
- set composite_version [composite_version $portversion [array get variations]]
- if { [catch {set ilist [concat $ilist [registry::installed $portname $composite_version]]} result] } {
- if {![string match "* not registered as installed." $result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port installed failed: $result" 1 status
- }
- }
- }
- } else {
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- ui_error "port installed failed: $result"
- set status 1
- }
- }
- }
- if { [llength $ilist] > 0 } {
- ui_notice "The following ports are currently installed:"
- foreach i [portlist_sortint $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]
- set extra ""
- set nvariants ""
- if {[macports::ui_isset ports_verbose]} {
- set regref [registry::open_entry $iname $iversion $irevision $ivariants [lindex $i 5]]
- set nvariants [registry::property_retrieve $regref negated_variants]
- if {$nvariants == 0} {
- set nvariants ""
- }
- set os_platform [registry::property_retrieve $regref os_platform]
- set os_major [registry::property_retrieve $regref os_major]
- set archs [registry::property_retrieve $regref archs]
- if {$os_platform != 0 && $os_platform ne "" && $os_major != 0 && $os_major ne ""} {
- append extra " platform='$os_platform $os_major'"
- }
- if {$archs != 0 && $archs ne ""} {
- append extra " archs='$archs'"
- }
- }
- if { $iactive == 0 } {
- puts " $iname @${iversion}_${irevision}${ivariants}${nvariants}${extra}"
- } elseif { $iactive == 1 } {
- puts " $iname @${iversion}_${irevision}${ivariants}${nvariants} (active)${extra}"
- }
- }
- } elseif { $restrictedList } {
- ui_notice "None of the specified ports are installed."
- } else {
- ui_notice "No ports are installed."
- }
-
- return $status
-}
-
-
-proc action_outdated { action portlist opts } {
- global private_options
- set status 0
-
- # If port names were supplied, limit ourselves to those ports, else check all installed ports
- set ilist {}
- set restrictedList 0
- if { [llength $portlist] || (![info exists private_options(ports_no_args)] || $private_options(ports_no_args) eq "no")} {
- set restrictedList 1
- foreach portspec $portlist {
- array set port $portspec
- set portname $port(name)
- set composite_version [composite_version $port(version) $port(variants)]
- if { [catch {set ilist [concat $ilist [registry::installed $portname $composite_version]]} result] } {
- if {![string match "* not registered as installed." $result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port outdated failed: $result" 1 status
- }
- }
- }
- } else {
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- ui_error "port installed failed: $result"
- set status 1
- }
- }
- }
-
- set num_outdated 0
- if { [llength $ilist] > 0 } {
- foreach i [portlist_sortint $ilist] {
-
- # Get information about the installed port
- set portname [lindex $i 0]
- set installed_version [lindex $i 1]
- set installed_revision [lindex $i 2]
- set installed_compound "${installed_version}_${installed_revision}"
-
- set is_active [lindex $i 4]
- if {$is_active == 0} {
- continue
- }
- set installed_epoch [lindex $i 5]
-
- # Get info about the port from the index
- if {[catch {set res [mportlookup $portname]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "search for portname $portname failed: $result" 1 status
- }
- if {[llength $res] < 2} {
- if {[macports::ui_isset ports_debug]} {
- puts "$portname ($installed_compound is installed; the port was not found in the port index)"
- }
- continue
- }
- array unset portinfo
- array set portinfo [lindex $res 1]
-
- # Get information about latest available version and revision
- if {![info exists portinfo(version)]} {
- ui_warn "$portname has no version field"
- continue
- }
- set latest_version $portinfo(version)
- set latest_revision 0
- if {[info exists portinfo(revision)] && $portinfo(revision) > 0} {
- set latest_revision $portinfo(revision)
- }
- set latest_compound "${latest_version}_${latest_revision}"
- set latest_epoch 0
- if {[info exists portinfo(epoch)]} {
- set latest_epoch $portinfo(epoch)
- }
-
- # Compare versions, first checking epoch, then version, then revision
- set epoch_comp_result [expr {$installed_epoch - $latest_epoch}]
- set comp_result [vercmp $installed_version $latest_version]
- if { $comp_result == 0 } {
- set comp_result [expr {$installed_revision - $latest_revision}]
- }
- set reason ""
- if {$epoch_comp_result != 0 && $installed_version != $latest_version} {
- if {($comp_result >= 0 && $epoch_comp_result < 0) || ($comp_result <= 0 && $epoch_comp_result > 0)} {
- set reason { (epoch $installed_epoch $relation $latest_epoch)}
- }
- set comp_result $epoch_comp_result
- } elseif {$comp_result == 0} {
- set regref [registry::open_entry $portname $installed_version $installed_revision [lindex $i 3] $installed_epoch]
- set os_platform_installed [registry::property_retrieve $regref os_platform]
- set os_major_installed [registry::property_retrieve $regref os_major]
- if {$os_platform_installed ne "" && $os_platform_installed != 0
- && $os_major_installed ne "" && $os_major_installed != 0
- && ($os_platform_installed != ${macports::os_platform} || $os_major_installed != ${macports::os_major})} {
- set comp_result -1
- set reason { (platform $os_platform_installed $os_major_installed != ${macports::os_platform} ${macports::os_major})}
- }
- }
-
- # Report outdated (or, for verbose, predated) versions
- if { $comp_result != 0 } {
-
- # Form a relation between the versions
- set flag ""
- if { $comp_result > 0 } {
- set relation ">"
- set flag "!"
- } else {
- set relation "<"
- }
-
- # Emit information
- if {$comp_result < 0 || [macports::ui_isset ports_verbose]} {
-
- if {$num_outdated == 0} {
- ui_notice "The following installed ports are outdated:"
- }
- incr num_outdated
-
- puts [format "%-30s %-24s %1s" $portname "$installed_compound $relation $latest_compound [subst $reason]" $flag]
- }
-
- }
- }
-
- if {$num_outdated == 0} {
- ui_notice "No installed ports are outdated."
- }
- } elseif { $restrictedList } {
- ui_notice "None of the specified ports are outdated."
- } else {
- ui_notice "No ports are installed."
- }
-
- return $status
-}
-
-
-proc action_contents { action portlist opts } {
- global global_options
- if {[require_portlist portlist]} {
- return 1
- }
- if {[info exists global_options(ports_contents_size)]} {
- set units {}
- if {[info exists global_options(ports_contents_units)]} {
- set units [complete_size_units $global_options(ports_contents_units)]
- }
- set outstring {[format "%12s $file" [filesize $file $units]]}
- } else {
- set outstring { $file}
- }
-
- foreachport $portlist {
- if { ![catch {set ilist [registry::installed $portname]} result] } {
- # set portname again since the one we were passed may not have had the correct case
- set portname [lindex $ilist 0 0]
- }
- set files [registry::port_registered $portname]
- if { $files != 0 } {
- if { [llength $files] > 0 } {
- ui_notice "Port $portname contains:"
- foreach file $files {
- puts [subst $outstring]
- }
- } else {
- ui_notice "Port $portname does not contain any files or is not active."
- }
- } else {
- ui_notice "Port $portname is not installed."
- }
- }
- registry::close_file_map
-
- return 0
-}
-
-# expand abbreviations of size units
-proc complete_size_units {units} {
- if {$units eq "K" || $units eq "Ki"} {
- return "KiB"
- } elseif {$units eq "k"} {
- return "kB"
- } elseif {$units eq "Mi"} {
- return "MiB"
- } elseif {$units eq "M"} {
- return "MB"
- } elseif {$units eq "Gi"} {
- return "GiB"
- } elseif {$units eq "G"} {
- return "GB"
- } else {
- return $units
- }
-}
-
-# Show space used by the given ports' files
-proc action_space {action portlist opts} {
- global global_options
- require_portlist portlist
-
- set units {}
- if {[info exists global_options(ports_space_units)]} {
- set units [complete_size_units $global_options(ports_space_units)]
- }
- set spaceall 0.0
- foreachport $portlist {
- set space 0.0
- set files [registry::port_registered $portname]
- if { $files != 0 } {
- if { [llength $files] > 0 } {
- foreach file $files {
- catch {
- set space [expr {$space + [file size $file]}]
- }
- }
- if {![info exists options(ports_space_total)] || $options(ports_space_total) ne "yes"} {
- set msg "[bytesize $space $units] $portname"
- if { $portversion != {} } {
- append msg " @$portversion"
- }
- puts $msg
- }
- set spaceall [expr {$space + $spaceall}]
- } else {
- puts stderr "Port $portname does not contain any file or is not active."
- }
- } else {
- puts stderr "Port $portname is not installed."
- }
- }
- if {[llength $portlist] > 1 || ([info exists options(ports_space_total)] && $options(ports_space_total) eq "yes")} {
- puts "[bytesize $spaceall $units] total"
- }
- return 0
-}
-
-proc action_variants { action portlist opts } {
- global global_variations
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
- foreachport $portlist {
- array unset portinfo
- if {$porturl eq ""} {
- # look up port
- if {[catch {mportlookup $portname} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Port $portname not found" 1 status
- }
-
- array set portinfo [lindex $result 1]
-
- set porturl $portinfo(porturl)
- set portdir $portinfo(portdir)
- }
-
- if {!([info exists options(ports_variants_index)] && $options(ports_variants_index) eq "yes")} {
- if {![info exists options(subport)]} {
- if {[info exists portinfo(name)]} {
- set options(subport) $portinfo(name)
- } else {
- set options(subport) $portname
- }
- }
- if {[catch {set mport [mportopen $porturl [array get options] [array get variations]]} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Unable to open port: $result" 1 status
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
- if {[info exists portdir]} {
- set portinfo(portdir) $portdir
- }
- } elseif {![info exists portinfo]} {
- ui_warn "port variants --index does not work with 'current' pseudo-port"
- continue
- }
-
- # set portname again since the one we were passed may not have had the correct case
- set portname $portinfo(name)
-
- # if this fails the port doesn't have any variants
- if {![info exists portinfo(variants)]} {
- ui_notice "$portname has no variants"
- } else {
- array unset vinfo
- # Use the new format if it exists.
- if {[info exists portinfo(vinfo)]} {
- array set vinfo $portinfo(vinfo)
- # Otherwise fall back to the old format.
- } elseif {[info exists portinfo(variant_desc)]} {
- array set vdescriptions $portinfo(variant_desc)
- }
-
- # print out all the variants
- ui_notice "$portname has the variants:"
- foreach v [lsort $portinfo(variants)] {
- unset -nocomplain vconflicts vdescription vrequires
- set varmodifier " "
- # Retrieve variants' information from the new format.
- if {[info exists vinfo]} {
- array unset variant
- array set variant $vinfo($v)
-
- # Retrieve conflicts, description, is_default, and
- # vrequires.
- if {[info exists variant(conflicts)]} {
- set vconflicts $variant(conflicts)
- }
- if {[info exists variant(description)]} {
- set vdescription $variant(description)
- }
-
- # XXX Keep these varmodifiers in sync with action_info, or create a wrapper for it
- if {[info exists variations($v)]} {
- set varmodifier " $variations($v)"
- } elseif {[info exists global_variations($v)]} {
- # selected by variants.conf, prefixed with (+)/(-)
- set varmodifier "($global_variations($v))"
- } elseif {[info exists variant(is_default)]} {
- set varmodifier "\[$variant(is_default)\]"
- }
- if {[info exists variant(requires)]} {
- set vrequires $variant(requires)
- }
- # Retrieve variants' information from the old format,
- # which only consists of the description.
- } elseif {[info exists vdescriptions($v)]} {
- set vdescription $vdescriptions($v)
- }
-
- if {[info exists vdescription]} {
- puts [wraplabel "$varmodifier$v" [string trim $vdescription] 0 [string repeat " " [expr 5 + [string length $v]]]]
- } else {
- puts "$varmodifier$v"
- }
- if {[info exists vconflicts]} {
- puts " * conflicts with [string trim $vconflicts]"
- }
- if {[info exists vrequires]} {
- puts " * requires [string trim $vrequires]"
- }
- }
- }
- }
-
- return $status
-}
-
-
-proc action_search { action portlist opts } {
- global private_options global_options
- set status 0
- if {![llength $portlist] && [info exists private_options(ports_no_args)] && $private_options(ports_no_args) eq "yes"} {
- ui_error "You must specify a search pattern"
- return 1
- }
-
- # Copy global options as we are going to modify the array
- array set options [array get global_options]
-
- if {[info exists options(ports_search_depends)] && $options(ports_search_depends) eq "yes"} {
- array unset options ports_search_depends
- set options(ports_search_depends_fetch) yes
- set options(ports_search_depends_extract) yes
- set options(ports_search_depends_build) yes
- set options(ports_search_depends_lib) yes
- set options(ports_search_depends_run) yes
- }
-
- # Array to hold given filters
- array set filters {}
- # Default matchstyle
- set filter_matchstyle "none"
- set filter_case no
- foreach { option } [array names options ports_search_*] {
- set opt [string range $option 13 end]
-
- if { $options($option) ne "yes" } {
- continue
- }
- switch -- $opt {
- exact -
- glob {
- set filter_matchstyle $opt
- continue
- }
- regex {
- set filter_matchstyle regexp
- continue
- }
- case-sensitive {
- set filter_case yes
- continue
- }
- line {
- continue
- }
- }
-
- set filters($opt) "yes"
- }
- # Set default search filter if none was given
- if { [array size filters] == 0 } {
- set filters(name) "yes"
- set filters(description) "yes"
- }
-
- set separator ""
- foreach portname $portlist {
- puts -nonewline $separator
-
- set searchstring $portname
- set matchstyle $filter_matchstyle
- if {$matchstyle eq "none"} {
- # Guess if the given string was a glob expression, if not do a substring search
- if {[string first "*" $portname] == -1 && [string first "?" $portname] == -1} {
- set searchstring "*$portname*"
- }
- set matchstyle glob
- }
-
- set res {}
- set portfound 0
- foreach { opt } [array get filters] {
- # Map from friendly name
- set opt [map_friendly_field_names $opt]
-
- if {[catch {eval set matches \[mportsearch \$searchstring $filter_case \$matchstyle $opt\]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "search for name $portname failed: $result" 1 status
- }
-
- set tmp {}
- foreach {name info} $matches {
- add_to_portlist tmp [concat [list name $name] $info]
- }
- set res [opUnion $res $tmp]
- }
- set res [portlist_sort $res]
-
- set joiner ""
- foreach info $res {
- array unset portinfo
- array set portinfo $info
-
- # XXX is this the right place to verify an entry?
- if {![info exists portinfo(name)]} {
- puts stderr "Invalid port entry, missing portname"
- continue
- }
- if {![info exists portinfo(description)]} {
- puts stderr "Invalid port entry for $portinfo(name), missing description"
- continue
- }
- if {![info exists portinfo(version)]} {
- puts stderr "Invalid port entry for $portinfo(name), missing version"
- continue
- }
-
- if {[macports::ui_isset ports_quiet]} {
- puts $portinfo(name)
- } else {
- if {[info exists options(ports_search_line)]
- && $options(ports_search_line) eq "yes"} {
- # check for ports without category, e.g. replaced_by stubs
- if {[info exists portinfo(categories)]} {
- puts "$portinfo(name)\t$portinfo(version)\t$portinfo(categories)\t$portinfo(description)"
- } else {
- # keep two consecutive tabs in order to provide consistent columns' content
- puts "$portinfo(name)\t$portinfo(version)\t\t$portinfo(description)"
- }
- } else {
- puts -nonewline $joiner
-
- puts -nonewline "$portinfo(name) @$portinfo(version)"
- if {[info exists portinfo(revision)] && $portinfo(revision) > 0} {
- puts -nonewline "_$portinfo(revision)"
- }
- if {[info exists portinfo(categories)]} {
- puts -nonewline " ([join $portinfo(categories) ", "])"
- }
- puts ""
- puts [wrap [join $portinfo(description)] 0 [string repeat " " 4]]
- }
- }
-
- set joiner "\n"
- set portfound 1
- }
- if { !$portfound } {
- ui_notice "No match for $portname found"
- } elseif {[llength $res] > 1} {
- if {(![info exists global_options(ports_search_line)]
- || $global_options(ports_search_line) ne "yes")} {
- ui_notice "\nFound [llength $res] ports."
- }
- }
-
- set separator "--\n"
- }
-
- array unset options
- array unset filters
-
- return $status
-}
-
-
-proc action_list { action portlist opts } {
- global private_options
- set status 0
-
- # Default to list all ports if no portnames are supplied
- if { ![llength $portlist] && [info exists private_options(ports_no_args)] && $private_options(ports_no_args) eq "yes"} {
- add_to_portlist portlist [list name "-all-"]
- }
-
- foreachport $portlist {
- if {$portname eq "-all-"} {
- if {[catch {set res [mportlistall]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "listing all ports failed: $result" 1 status
- }
- } else {
- set search_string [regex_pat_sanitize $portname]
- if {[catch {set res [mportsearch ^$search_string\$ no]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "search for portname $search_string failed: $result" 1 status
- }
- }
-
- foreach {name array} $res {
- array unset portinfo
- array set portinfo $array
- set outdir ""
- if {[info exists portinfo(portdir)]} {
- set outdir $portinfo(portdir)
- }
- puts [format "%-30s @%-14s %s" $portinfo(name) $portinfo(version) $outdir]
- }
- }
-
- return $status
-}
-
-
-proc action_echo { action portlist opts } {
- global global_options
-
- # Simply echo back the port specs given to this command
- foreachport $portlist {
- if {![macports::ui_isset ports_quiet]} {
- set opts {}
- foreach { key value } [array get options] {
- if {![info exists global_options($key)]} {
- lappend opts "$key=$value"
- }
- }
-
- set composite_version [composite_version $portversion [array get variations] 1]
- if { $composite_version ne "" } {
- set ver_field "@$composite_version"
- } else {
- set ver_field ""
- }
- puts [format "%-30s %s %s" $portname $ver_field [join $opts " "]]
- } else {
- puts "$portname"
- }
- }
-
- return 0
-}
-
-
-proc action_portcmds { action portlist opts } {
- # Operations on the port's directory and Portfile
- global env boot_env current_portdir
-
- array set local_options $opts
-
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
- foreachport $portlist {
- array unset portinfo
- # If we have a url, use that, since it's most specific, otherwise try to map the portname to a url
- if {$porturl eq ""} {
-
- # Verify the portname, getting portinfo to map to a porturl
- if {[catch {set res [mportlookup $portname]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $res] < 2} {
- break_softcontinue "Port $portname not found" 1 status
- }
- array set portinfo [lindex $res 1]
- set porturl $portinfo(porturl)
- set portname $portinfo(name)
- }
-
-
- # Calculate portdir, porturl, and portfile from initial porturl
- set portdir [file normalize [macports::getportdir $porturl]]
- set porturl "file://${portdir}"; # Rebuild url so it's fully qualified
- set portfile "${portdir}/Portfile"
-
- # Now execute the specific action
- if {[file readable $portfile]} {
- switch -- $action {
- cat {
- # Copy the portfile to standard output
- set f [open $portfile RDONLY]
- while { ![eof $f] } {
- puts -nonewline [read $f 4096]
- }
- close $f
- }
-
- edit {
- # Edit the port's portfile with the user's editor
-
- # Restore our entire environment from start time.
- # We need it to evaluate the editor, and the editor
- # may want stuff from it as well, like TERM.
- array unset env_save; array set env_save [array get env]
- array unset env *
- if {${macports::macosx_version} eq "10.5"} {
- unsetenv *
- }
- array set env [array get boot_env]
-
- # Find an editor to edit the portfile
- set editor ""
- set editor_var "ports_${action}_editor"
- if {[info exists local_options($editor_var)]} {
- set editor [join $local_options($editor_var)]
- } else {
- foreach ed { MP_EDITOR VISUAL EDITOR } {
- if {[info exists env($ed)]} {
- set editor $env($ed)
- break
- }
- }
- }
-
- # Use a reasonable canned default if no editor specified or set in env
- if { $editor eq "" } { set editor "/usr/bin/vi" }
-
- # Invoke the editor
- if {[catch {eval exec >@stdout <@stdin 2>@stderr $editor {$portfile}} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "unable to invoke editor $editor: $result" 1 status
- }
-
- # Restore internal MacPorts environment
- array unset env *
- if {${macports::macosx_version} eq "10.5"} {
- unsetenv *
- }
- array set env [array get env_save]
- }
-
- dir {
- # output the path to the port's directory
- puts $portdir
- }
-
- work {
- # output the path to the port's work directory
- set workpath [macports::getportworkpath_from_portdir $portdir $portname]
- if {[file exists $workpath]} {
- puts $workpath
- }
- }
-
- cd {
- # Change to the port's directory, making it the default
- # port for any future commands
- set current_portdir $portdir
- }
-
- url {
- # output the url of the port's directory, suitable to feed back in later as a port descriptor
- puts $porturl
- }
-
- file {
- # output the path to the port's portfile
- puts $portfile
- }
-
- logfile {
- set logfile [file join [macports::getportlogpath $portdir $portname] "main.log"]
- if {[file isfile $logfile]} {
- puts $logfile
- } else {
- ui_error "Log file not found for port in $portdir"
- }
- }
-
- gohome {
- set homepage ""
-
- # Get the homepage as read from PortIndex
- if {[info exists portinfo(homepage)]} {
- set homepage $portinfo(homepage)
- }
-
- # If not available, get the homepage for the port by opening the Portfile
- if {$homepage eq "" && ![catch {set ctx [mportopen $porturl]} result]} {
- array set portinfo [mportinfo $ctx]
- if {[info exists portinfo(homepage)]} {
- set homepage $portinfo(homepage)
- }
- mportclose $ctx
- }
-
- # Try to open a browser to the homepage for the given port
- if { $homepage ne "" } {
- if {[catch {system "${macports::autoconf::open_path} '$homepage'"} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "unable to invoke browser using ${macports::autoconf::open_path}: $result" 1 status
- }
- } else {
- ui_error [format "No homepage for %s" $portname]
- }
- }
- }
- } else {
- break_softcontinue "Could not read $portfile" 1 status
- }
- }
-
- return $status
-}
-
-
-proc action_sync { action portlist opts } {
- global global_options
-
- set status 0
- if {[catch {mportsync [array get global_options]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- ui_msg "port sync failed: $result"
- set status 1
- }
-
- return $status
-}
-
-
-proc action_target { action portlist opts } {
- global global_variations
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
- if {($action eq "install" || $action eq "archive") && [prefix_unwritable] && ![macports::global_option_isset ports_dryrun]} {
- return 1
- }
- foreachport $portlist {
- array unset portinfo
- # If we have a url, use that, since it's most specific
- # otherwise try to map the portname to a url
- if {$porturl eq ""} {
- # Verify the portname, getting portinfo to map to a porturl
- if {[catch {set res [mportlookup $portname]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $res] < 2} {
- # don't error for ports that are installed but not in the tree
- if {[registry::entry_exists_for_name $portname]} {
- ui_warn "Skipping $portname (not in the ports tree)"
- continue
- } else {
- break_softcontinue "Port $portname not found" 1 status
- }
- }
- array set portinfo [lindex $res 1]
- set porturl $portinfo(porturl)
- }
-
- # use existing variants iff none were explicitly requested
- if {[array get requested_variations] eq "" && [array get variations] ne ""} {
- array unset requested_variations
- array set requested_variations [array get variations]
- }
-
- # Add any global_variations to the variations
- # specified for the port
- foreach { variation value } [array get global_variations] {
- if { ![info exists requested_variations($variation)] } {
- set requested_variations($variation) $value
- }
- }
-
- # If version was specified, save it as a version glob for use
- # in port actions (e.g. clean).
- if {[string length $portversion]} {
- set options(ports_version_glob) $portversion
- }
- # if installing, mark the port as explicitly requested
- if {$action eq "install"} {
- if {![info exists options(ports_install_unrequested)]} {
- set options(ports_requested) 1
- }
- # we actually activate as well
- set target activate
- } elseif {$action eq "archive"} {
- set target install
- } else {
- set target $action
- }
- if {![info exists options(subport)]} {
- if {[info exists portinfo(name)]} {
- set options(subport) $portinfo(name)
- } else {
- set options(subport) $portname
- }
- }
- if {[catch {set workername [mportopen $porturl [array get options] [array get requested_variations]]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "Unable to open port: $result" 1 status
- }
- if {[catch {set result [mportexec $workername $target]} result]} {
- global errorInfo
- mportclose $workername
- ui_debug "$errorInfo"
- break_softcontinue "Unable to execute port: $result" 1 status
- }
-
- mportclose $workername
-
- # Process any error that wasn't thrown and handled already
- if {$result} {
- print_tickets_url
- break_softcontinue "Processing of port $portname failed" 1 status
- }
- }
-
- if {$status == 0 && $action eq "install" && ![macports::global_option_isset ports_dryrun]} {
- array set options $opts
- if {![info exists options(ports_nodeps)] && ![info exists options(ports_install_no-rev-upgrade)] && ${macports::revupgrade_autorun}} {
- set status [action_revupgrade $action $portlist $opts]
- }
- }
-
- return $status
-}
-
-
-proc action_exit { action portlist opts } {
- # Return a semaphore telling the main loop to quit
- return -999
-}
-
-
-##########################################
-# Command Parsing
-##########################################
-proc moreargs {} {
- global cmd_argn cmd_argc
- return [expr {$cmd_argn < $cmd_argc}]
-}
-
-
-proc lookahead {} {
- global cmd_argn cmd_argc cmd_argv
- if {$cmd_argn < $cmd_argc} {
- return [lindex $cmd_argv $cmd_argn]
- } else {
- return _EOF_
- }
-}
-
-
-proc advance {} {
- global cmd_argn
- incr cmd_argn
-}
-
-
-proc match s {
- if {[lookahead] == $s} {
- advance
- return 1
- }
- return 0
-}
-
-# action_array specifies which action to run on the given command
-# and if the action wants an expanded portlist.
-# The value is a list of the form {action expand},
-# where action is a string and expand a value:
-# 0 none Does not expect any text argument
-# 1 strings Expects some strings as text argument
-# 2 ports Wants an expanded list of ports as text argument
-global action_array
-
-# Define global constants
-const ACTION_ARGS_NONE 0
-const ACTION_ARGS_STRINGS 1
-const ACTION_ARGS_PORTS 2
-
-array set action_array [list \
- usage [list action_usage [ACTION_ARGS_STRINGS]] \
- help [list action_help [ACTION_ARGS_STRINGS]] \
- \
- echo [list action_echo [ACTION_ARGS_PORTS]] \
- \
- info [list action_info [ACTION_ARGS_PORTS]] \
- location [list action_location [ACTION_ARGS_PORTS]] \
- notes [list action_notes [ACTION_ARGS_PORTS]] \
- provides [list action_provides [ACTION_ARGS_STRINGS]] \
- log [list action_log [ACTION_ARGS_PORTS]] \
- \
- activate [list action_activate [ACTION_ARGS_PORTS]] \
- deactivate [list action_deactivate [ACTION_ARGS_PORTS]] \
- \
- select [list action_select [ACTION_ARGS_STRINGS]] \
- \
- sync [list action_sync [ACTION_ARGS_NONE]] \
- selfupdate [list action_selfupdate [ACTION_ARGS_NONE]] \
- \
- setrequested [list action_setrequested [ACTION_ARGS_PORTS]] \
- unsetrequested [list action_setrequested [ACTION_ARGS_PORTS]] \
- \
- upgrade [list action_upgrade [ACTION_ARGS_PORTS]] \
- rev-upgrade [list action_revupgrade [ACTION_ARGS_NONE]] \
- reclaim [list action_reclaim [ACTION_ARGS_NONE]] \
- doctor [list action_doctor [ACTION_ARGS_NONE]] \
- \
- version [list action_version [ACTION_ARGS_NONE]] \
- platform [list action_platform [ACTION_ARGS_NONE]] \
- \
- uninstall [list action_uninstall [ACTION_ARGS_PORTS]] \
- \
- installed [list action_installed [ACTION_ARGS_PORTS]] \
- outdated [list action_outdated [ACTION_ARGS_PORTS]] \
- contents [list action_contents [ACTION_ARGS_PORTS]] \
- space [list action_space [ACTION_ARGS_PORTS]] \
- dependents [list action_dependents [ACTION_ARGS_PORTS]] \
- rdependents [list action_dependents [ACTION_ARGS_PORTS]] \
- deps [list action_deps [ACTION_ARGS_PORTS]] \
- rdeps [list action_deps [ACTION_ARGS_PORTS]] \
- variants [list action_variants [ACTION_ARGS_PORTS]] \
- \
- search [list action_search [ACTION_ARGS_STRINGS]] \
- list [list action_list [ACTION_ARGS_PORTS]] \
- \
- edit [list action_portcmds [ACTION_ARGS_PORTS]] \
- cat [list action_portcmds [ACTION_ARGS_PORTS]] \
- dir [list action_portcmds [ACTION_ARGS_PORTS]] \
- work [list action_portcmds [ACTION_ARGS_PORTS]] \
- cd [list action_portcmds [ACTION_ARGS_PORTS]] \
- url [list action_portcmds [ACTION_ARGS_PORTS]] \
- file [list action_portcmds [ACTION_ARGS_PORTS]] \
- logfile [list action_portcmds [ACTION_ARGS_PORTS]] \
- gohome [list action_portcmds [ACTION_ARGS_PORTS]] \
- \
- fetch [list action_target [ACTION_ARGS_PORTS]] \
- checksum [list action_target [ACTION_ARGS_PORTS]] \
- extract [list action_target [ACTION_ARGS_PORTS]] \
- patch [list action_target [ACTION_ARGS_PORTS]] \
- configure [list action_target [ACTION_ARGS_PORTS]] \
- build [list action_target [ACTION_ARGS_PORTS]] \
- destroot [list action_target [ACTION_ARGS_PORTS]] \
- install [list action_target [ACTION_ARGS_PORTS]] \
- clean [list action_target [ACTION_ARGS_PORTS]] \
- test [list action_target [ACTION_ARGS_PORTS]] \
- lint [list action_target [ACTION_ARGS_PORTS]] \
- livecheck [list action_target [ACTION_ARGS_PORTS]] \
- distcheck [list action_target [ACTION_ARGS_PORTS]] \
- mirror [list action_target [ACTION_ARGS_PORTS]] \
- load [list action_target [ACTION_ARGS_PORTS]] \
- unload [list action_target [ACTION_ARGS_PORTS]] \
- distfiles [list action_target [ACTION_ARGS_PORTS]] \
- \
- archivefetch [list action_target [ACTION_ARGS_PORTS]] \
- archive [list action_target [ACTION_ARGS_PORTS]] \
- unarchive [list action_target [ACTION_ARGS_PORTS]] \
- dmg [list action_target [ACTION_ARGS_PORTS]] \
- mdmg [list action_target [ACTION_ARGS_PORTS]] \
- dpkg [list action_target [ACTION_ARGS_PORTS]] \
- mpkg [list action_target [ACTION_ARGS_PORTS]] \
- pkg [list action_target [ACTION_ARGS_PORTS]] \
- portpkg [list action_target [ACTION_ARGS_PORTS]] \
- rpm [list action_target [ACTION_ARGS_PORTS]] \
- srpm [list action_target [ACTION_ARGS_PORTS]] \
- \
- quit [list action_exit [ACTION_ARGS_NONE]] \
- exit [list action_exit [ACTION_ARGS_NONE]] \
-]
-
-# Expand "action".
-# Returns an action proc, or a list of matching action procs, or the action passed in
-proc find_action { action } {
- global action_array
-
- if { ! [info exists action_array($action)] } {
- set guess [guess_action $action]
- if { [info exists action_array($guess)] } {
- return $guess
- }
- return $guess
- }
-
- return $action
-}
-
-# Expand action
-# If there's more than one match, return the next possibility
-proc find_action_proc { action } {
- global action_array
-
- set action_proc ""
- if { [info exists action_array($action)] } {
- set action_proc [lindex $action_array($action) 0]
- } else {
- set action [complete_action $action]
- if { [info exists action_array($action)] } {
- set action_proc [lindex $action_array($action) 0]
- }
- }
-
- return $action_proc
-}
-
-proc get_action_proc { action } {
- global action_array
-
- set action_proc ""
- if { [info exists action_array($action)] } {
- set action_proc [lindex $action_array($action) 0]
- }
-
- return $action_proc
-}
-
-# Returns whether an action expects text arguments at all,
-# expects text arguments or wants an expanded list of ports
-# Return values are constants:
-# [ACTION_ARGS_NONE] Does not expect any text argument
-# [ACTION_ARGS_STRINGS] Expects some strings as text argument
-# [ACTION_ARGS_PORTS] Wants an expanded list of ports as text argument
-proc action_needs_portlist { action } {
- global action_array
-
- set ret 0
- if {[info exists action_array($action)]} {
- set ret [lindex $action_array($action) 1]
- }
-
- return $ret
-}
-
-# cmd_opts_array specifies which arguments the commands accept
-# Commands not listed here do not accept any arguments
-# Syntax if {option argn}
-# Where option is the name of the option and argn specifies how many arguments
-# this argument takes
-global cmd_opts_array
-array set cmd_opts_array {
- edit {{editor 1}}
- info {category categories depends_fetch depends_extract
- depends_build depends_lib depends_run
- depends description epoch fullname heading homepage index license
- line long_description
- maintainer maintainers name platform platforms portdir pretty
- replaced_by revision subports variant variants version}
- contents {size {units 1}}
- deps {index no-build}
- rdeps {index no-build full}
- rdependents {full}
- search {case-sensitive category categories depends_fetch
- depends_extract depends_build depends_lib depends_run
- depends description epoch exact glob homepage line
- long_description maintainer maintainers name platform
- platforms portdir regex revision variant variants version}
- selfupdate {nosync}
- space {{units 1} total}
- activate {no-exec}
- deactivate {no-exec}
- install {no-rev-upgrade unrequested}
- uninstall {follow-dependents follow-dependencies no-exec}
- variants {index}
- clean {all archive dist work logs}
- mirror {new}
- lint {nitpick}
- select {list set show summary}
- log {{phase 1} {level 1}}
- upgrade {force enforce-variants no-replace no-rev-upgrade}
- rev-upgrade {id-loadcmd-check}
- doctor {quiet}
-}
-
-##
-# Checks whether the given option is valid
-#
-# @param action for which action
-# @param option the prefix of the option to check
-# @return list of pairs {name argc} for all matching options
-proc cmd_option_matches {action option} {
- global cmd_opts_array
-
- # This could be so easy with lsearch -index,
- # but that's only available as of Tcl 8.5
-
- if {![info exists cmd_opts_array($action)]} {
- return {}
- }
-
- set result {}
-
- foreach item $cmd_opts_array($action) {
- if {[llength $item] == 1} {
- set name $item
- set argc 0
- } else {
- set name [lindex $item 0]
- set argc [lindex $item 1]
- }
-
- if {$name == $option} {
- set result [list [list $name $argc]]
- break
- } elseif {[string first $option $name] == 0} {
- lappend result [list $name $argc]
- }
- }
-
- return $result
-}
-
-# Parse global options
-#
-# Note that this is called several times:
-# (1) Initially, to parse options that will be constant across all commands
-# (options that come prior to any command, frozen into global_options_base)
-# (2) Following each command (to parse options that will be unique to that command
-# (the global_options array is reset to global_options_base prior to each command)
-#
-proc parse_options { action ui_options_name global_options_name } {
- upvar $ui_options_name ui_options
- upvar $global_options_name global_options
- global cmdname cmd_opts_array
-
- while {[moreargs]} {
- set arg [lookahead]
-
- if {[string index $arg 0] ne "-"} {
- break
- } elseif {[string index $arg 1] eq "-"} {
- # Process long arguments
- switch -- $arg {
- -- { # This is the options terminator; do no further option processing
- advance; break
- }
- default {
- set key [string range $arg 2 end]
- set kopts [cmd_option_matches $action $key]
- if {[llength $kopts] == 0} {
- return -code error "${action} does not accept --${key}"
- } elseif {[llength $kopts] > 1} {
- set errlst {}
- foreach e $kopts {
- lappend errlst "--[lindex $e 0]"
- }
- return -code error "\"port ${action} --${key}\" is ambiguous: \n port ${action} [join $errlst "\n port ${action} "]"
- }
- set key [lindex $kopts 0 0]
- set kargc [lindex $kopts 0 1]
- if {$kargc == 0} {
- set global_options(ports_${action}_${key}) yes
- } else {
- set args {}
- while {[moreargs] && $kargc > 0} {
- advance
- lappend args [lookahead]
- set kargc [expr {$kargc - 1}]
- }
- if {$kargc > 0} {
- return -code error "--${key} expects [expr {$kargc + [llength $args]}] parameters!"
- }
- set global_options(ports_${action}_${key}) $args
- }
- }
- }
- } else {
- # Process short arg(s)
- set opts [string range $arg 1 end]
- foreach c [split $opts {}] {
- switch -- $c {
- v {
- set ui_options(ports_verbose) yes
- }
- d {
- set ui_options(ports_debug) yes
- # debug implies verbose
- set ui_options(ports_verbose) yes
- }
- q {
- set ui_options(ports_quiet) yes
- }
- p {
- # Ignore errors while processing within a command
- set ui_options(ports_processall) yes
- }
- f {
- set global_options(ports_force) yes
- }
- o {
- set global_options(ports_ignore_different) yes
- }
- n {
- set global_options(ports_nodeps) yes
- }
- u {
- set global_options(port_uninstall_old) yes
- }
- R {
- set global_options(ports_do_dependents) yes
- }
- s {
- set global_options(ports_source_only) yes
- }
- b {
- set global_options(ports_binary_only) yes
- }
- c {
- set global_options(ports_autoclean) yes
- }
- k {
- set global_options(ports_autoclean) no
- }
- t {
- set global_options(ports_trace) yes
- }
- y {
- set global_options(ports_dryrun) yes
- }
- F {
- # Name a command file to process
- advance
- if {[moreargs]} {
- lappend ui_options(ports_commandfiles) [lookahead]
- }
- }
- D {
- advance
- if {[moreargs]} {
- cd [lookahead]
- }
- break
- }
- default {
- print_usage; exit 1
- }
- }
- }
- }
-
- advance
- }
-}
-
-# acquire exclusive registry lock for actions that need it
-# returns 1 if locked, 0 otherwise
-proc lock_reg_if_needed {action} {
- switch -- $action {
- activate -
- deactivate -
- setrequested -
- unsetrequested -
- upgrade -
- uninstall -
- install {
- registry::exclusive_lock
- return 1
- }
- }
- return 0
-}
-
-proc process_cmd { argv } {
- global cmd_argc cmd_argv cmd_argn \
- global_options global_options_base private_options ui_options \
- current_portdir
- set cmd_argv $argv
- set cmd_argc [llength $argv]
- set cmd_argn 0
-
- set action_status 0
-
- # Process an action if there is one
- while {($action_status == 0 || [macports::ui_isset ports_processall]) && [moreargs]} {
- set action [lookahead]
- advance
-
- # Handle command separator
- if { $action == ";" } {
- continue
- }
-
- # Handle a comment
- if { [string index $action 0] == "#" } {
- while { [moreargs] } { advance }
- break
- }
-
- set locked [lock_reg_if_needed $action]
- # Always start out processing an action in current_portdir
- cd $current_portdir
-
- # Reset global_options from base before each action, as we munge it just below...
- array unset global_options
- array set global_options $global_options_base
-
- # Find an action to execute
- set actions [find_action $action]
- if {[llength $actions] == 1} {
- set action [lindex $actions 0]
- set action_proc [get_action_proc $action]
- } else {
- if {[llength $actions] > 1} {
- ui_error "\"port ${action}\" is ambiguous: \n port [join $actions "\n port "]"
- } else {
- ui_error "Unrecognized action \"port $action\""
- }
- set action_status 1
- break
- }
-
- # Parse options that will be unique to this action
- # (to avoid abiguity with -variants and a default port, either -- must be
- # used to terminate option processing, or the pseudo-port current must be specified).
- if {[catch {parse_options $action ui_options global_options} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- ui_error $result
- set action_status 1
- break
- }
-
- # What kind of arguments does the command expect?
- set expand [action_needs_portlist $action]
-
- # Parse action arguments, setting a special flag if there were none
- # We otherwise can't tell the difference between arguments that evaluate
- # to the empty set, and the empty set itself.
- set portlist {}
- switch -- [lookahead] {
- ; -
- _EOF_ {
- set private_options(ports_no_args) yes
- }
- default {
- if {[ACTION_ARGS_NONE] == $expand} {
- ui_error "$action does not accept string arguments"
- set action_status 1
- break
- } elseif {[ACTION_ARGS_STRINGS] == $expand} {
- while { [moreargs] && ![match ";"] } {
- lappend portlist [lookahead]
- advance
- }
- } elseif {[ACTION_ARGS_PORTS] == $expand} {
- # Parse port specifications into portlist
- if {![portExpr portlist]} {
- ui_error "Improper expression syntax while processing parameters"
- set action_status 1
- break
- }
- }
- }
- }
-
- # execute the action
- set action_status [$action_proc $action $portlist [array get global_options]]
-
- # unlock if needed
- if {$locked} {
- registry::exclusive_unlock
- }
-
- # Print notifications of just-activated ports.
- portclient::notifications::display
-
- # semaphore to exit
- if {$action_status == -999} break
- }
-
- return $action_status
-}
-
-
-proc complete_portname { text state } {
- global complete_choices complete_position
-
- if {$state == 0} {
- set complete_position 0
- set complete_choices {}
-
- # Build a list of ports with text as their prefix
- if {[catch {set res [mportsearch "${text}*" false glob]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "search for portname $pattern failed: $result"
- }
- foreach {name info} $res {
- lappend complete_choices $name
- }
- }
-
- set word [lindex $complete_choices $complete_position]
- incr complete_position
-
- return $word
-}
-
-
-# return text action beginning with $text
-proc complete_action { text state } {
- global action_array complete_choices complete_position
-
- if {$state == 0} {
- set complete_position 0
- set complete_choices [array names action_array "[string tolower $text]*"]
- }
-
- set word [lindex $complete_choices $complete_position]
- incr complete_position
-
- return $word
-}
-
-# return all actions beginning with $text
-proc guess_action { text } {
- global action_array
-
- return [array names action_array "[string tolower $text]*"]
-
- if { [llength $complete_choices ] == 1 } {
- return [lindex $complete_choices 0]
- }
-
- return {}
-}
-
-proc attempt_completion { text word start end } {
- # If the word starts with '~', or contains '.' or '/', then use the build-in
- # completion to complete the word
- if { [regexp {^~|[/.]} $word] } {
- return ""
- }
-
- # Decide how to do completion based on where we are in the string
- set prefix [string range $text 0 [expr {$start - 1}]]
-
- # If only whitespace characters preceed us, or if the
- # previous non-whitespace character was a ;, then we're
- # an action (the first word of a command)
- if { [regexp {(^\s*$)|(;\s*$)} $prefix] } {
- return complete_action
- }
-
- # Otherwise, do completion on portname
- return complete_portname
-}
-
-
-proc get_next_cmdline { in out use_readline prompt linename } {
- upvar $linename line
-
- set line ""
- while { $line eq "" } {
-
- if {$use_readline} {
- set len [readline read -attempted_completion attempt_completion line $prompt]
- } else {
- puts -nonewline $out $prompt
- flush $out
- set len [gets $in line]
- }
-
- if { $len < 0 } {
- return -1
- }
-
- set line [string trim $line]
-
- if { $use_readline && $line ne "" } {
- rl_history add $line
- }
- }
-
- return [llength $line]
-}
-
-
-proc process_command_file { in } {
- global current_portdir
-
- # Initialize readline
- set isstdin [string match $in "stdin"]
- set name "port"
- set use_readline [expr {$isstdin && [readline init $name]}]
- set history_file [file normalize "${macports::macports_user_dir}/history"]
-
- # Read readline history
- if {$use_readline && [file isdirectory $macports::macports_user_dir]} {
- rl_history read $history_file
- rl_history stifle 100
- }
-
- # Be noisy, if appropriate
- set noisy [expr $isstdin && ![macports::ui_isset ports_quiet]]
- if { $noisy } {
- puts "MacPorts [macports::version]"
- puts "Entering interactive mode... (\"help\" for help, \"quit\" to quit)"
- }
-
- # Main command loop
- set exit_status 0
- while { $exit_status == 0 || $isstdin || [macports::ui_isset ports_processall] } {
-
- # Calculate our prompt
- if { $noisy } {
- set shortdir [eval file join [lrange [file split $current_portdir] end-1 end]]
- set prompt "\[$shortdir\] > "
- } else {
- set prompt ""
- }
-
- # Get a command line
- if { [get_next_cmdline $in stdout $use_readline $prompt line] <= 0 } {
- puts ""
- break
- }
-
- # Process the command
- set exit_status [process_cmd $line]
-
- # Check for semaphore to exit
- if {$exit_status == -999} {
- set exit_status 0
- break
- }
- }
-
- # Create macports user directory if it does not exist yet
- if {$use_readline && ![file isdirectory $macports::macports_user_dir]} {
- file mkdir $macports::macports_user_dir
- }
- # Save readine history
- if {$use_readline && [file isdirectory $macports::macports_user_dir]} {
- rl_history write $history_file
- }
-
- # Say goodbye
- if { $noisy } {
- puts "Goodbye"
- }
-
- return $exit_status
-}
-
-
-proc process_command_files { filelist } {
- set exit_status 0
-
- # For each file in the command list, process commands
- # in the file
- foreach file $filelist {
- if {$file eq "-"} {
- set in stdin
- } else {
- if {[catch {set in [open $file]} result]} {
- fatal "Failed to open command file; $result"
- }
- }
-
- set exit_status [process_command_file $in]
-
- if {$in ne "stdin"} {
- close $in
- }
-
- # Exit on first failure unless -p was given
- if {$exit_status != 0 && ![macports::ui_isset ports_processall]} {
- return $exit_status
- }
- }
-
- return $exit_status
-}
-
-namespace eval portclient::progress {
- ##
- # Maximum width of the progress bar or indicator when displaying it.
- variable maxWidth 50
-
- ##
- # The start time of the last progress callback as returned by [clock time].
- # Since only one progress indicator is active at a time, this variable is
- # shared between the different variants of progress functions.
- variable startTime
-
- ##
- # Delay in milliseconds after the start of the operation before deciding
- # that showing a progress bar makes sense.
- variable showTimeThreshold 500
-
- ##
- # Percentage value between 0 and 1 that must not have been reached yet when
- # $showTimeThreshold has passed for a progress bar to be shown. If the
- # operation has proceeded above e.g. 75% after 500ms we won't bother
- # displaying a progress indicator anymore -- the operation will be finished
- # in well below a second anyway.
- variable showPercentageThreshold 0.75
-
- ##
- # Boolean indication whether the progress indicator should be shown or is
- # still hidden because the current operation didn't need enough time for
- # a progress indicator to make sense, yet.
- variable show no
-
- ##
- # Initialize the progress bar display delay; call this from the start
- # action of the progress functions.
- proc initDelay {} {
- variable show
- variable startTime
-
- set startTime [clock milliseconds]
- set show no
- }
-
- ##
- # Determine whether a progress bar should be shown for the current
- # operation in its current state. You must have called initDelay for the
- # current operation before calling this method.
- #
- # @param cur
- # Current progress in abstract units.
- # @param total
- # Total number of abstract units to be processed, if known. Pass
- # 0 if unknown.
- # @return
- # "yes", if the progress indicator should be shown, "no" otherwise.
- proc showProgress {cur total} {
- variable show
- variable startTime
- variable showTimeThreshold
- variable showPercentageThreshold
-
- if {$show eq "yes"} {
- return yes
- } else {
- if {[expr {[clock milliseconds] - $startTime}] > $showTimeThreshold &&
- ($total == 0 || [expr {double($cur) / double($total)}] < $showPercentageThreshold)} {
- set show yes
- }
- return $show
- }
- }
-
- ##
- # Progress callback for generic operations executed by macports 1.0.
- #
- # @param action
- # One of "start", "update", "intermission" or "finish", where start
- # will be called before any number of update calls, interrupted by
- # any number of intermission calls (called because other output is
- # being produced), followed by one call to finish.
- # @param args
- # A list of variadic args that differ for each action. For "start",
- # "intermission" and "finish", the args are empty and unused. For
- # "update", args contains $cur and $total, where $cur is the current
- # number of units processed and $total is the total number of units
- # to be processed. If the total is not known, it is 0.
- proc generic {action args} {
- global env
- variable maxWidth
-
- switch -nocase -- $action {
- start {
- initDelay
- }
- update {
- # the for loop is a simple hack because Tcl 8.4 doesn't have
- # lassign
- foreach {now total} $args {
- if {[showProgress $now $total] eq "yes"} {
- set barPrefix " "
- set barPrefixLen [string length $barPrefix]
- if {$total != 0} {
- progressbar $now $total [expr {min($maxWidth, $env(COLUMNS) - $barPrefixLen)}] $barPrefix
- } else {
- unprogressbar [expr {min($maxWidth, $env(COLUMNS) - $barPrefixLen)}] $barPrefix
- }
- }
- }
- }
- intermission -
- finish {
- # erase to start of line
- ::term::ansi::send::esol
- # return cursor to start of line
- puts -nonewline "\r"
- flush stdout
- }
- }
-
- return 0
- }
-
- ##
- # Progress callback for downloads executed by macports 1.0.
- #
- # This is essentially a cURL progress callback.
- #
- # @param action
- # One of "start", "update" or "finish", where start will be called
- # before any number of update calls, followed by one call to finish.
- # @param args
- # A list of variadic args that differ for each action. For "start",
- # contains a single argument "ul" or "dl" indicating whether this is
- # an up- or download. For "update", contains the arguments
- # ("ul"|"dl") $total $now $speed where ul/dl are as for start, and
- # total, now and speed are doubles indicating the total transfer
- # size, currently transferred amount and average speed per second in
- # bytes. Unused for "finish".
- proc download {action args} {
- global env
- variable maxWidth
-
- switch -nocase -- $action {
- start {
- initDelay
- }
- update {
- # the for loop is a simple hack because Tcl 8.4 doesn't have
- # lassign
- foreach {type total now speed} $args {
- if {[showProgress $now $total] eq "yes"} {
- set barPrefix " "
- set barPrefixLen [string length $barPrefix]
- if {$total != 0} {
- set barSuffix [format " speed: %-13s" "[bytesize $speed {} "%.1f"]/s"]
- set barSuffixLen [string length $barSuffix]
-
- set barLen [expr {min($maxWidth, $env(COLUMNS) - $barPrefixLen - $barSuffixLen)}]
- progressbar $now $total $barLen $barPrefix $barSuffix
- } else {
- set barSuffix [format " %-10s speed: %-13s" [bytesize $now {} "%6.1f"] "[bytesize $speed {} "%.1f"]/s"]
- set barSuffixLen [string length $barSuffix]
-
- set barLen [expr {min($maxWidth, $env(COLUMNS) - $barPrefixLen - $barSuffixLen)}]
- unprogressbar $barLen $barPrefix $barSuffix
- }
- }
- }
- }
- finish {
- # erase to start of line
- ::term::ansi::send::esol
- # return cursor to start of line
- puts -nonewline "\r"
- flush stdout
- }
- }
-
- return 0
- }
-
- ##
- # Draw a progress bar using unicode block drawing characters
- #
- # @param current
- # The current progress value.
- # @param total
- # The progress value representing 100%.
- # @param width
- # The width in characters of the progress bar. This includes percentage
- # output, which takes up 8 characters.
- # @param prefix
- # Prefix to be printed in front of the progress bar.
- # @param suffix
- # Suffix to be printed after the progress bar.
- proc progressbar {current total width {prefix ""} {suffix ""}} {
- # Subtract the width of the percentage output, also subtract the two
- # characters [ and ] bounding the progress bar.
- set percentageWidth 8
- set barWidth [expr {entier($width) - $percentageWidth - 2}]
-
- # Map the range (0, $total) to (0, 4 * $width) where $width is the maximum
- # numebr of characters to be printed for the progress bar. Multiply the
- # upper bound with 8 because we have 8 sub-states per character.
- set barProgress [expr {entier(round(($current * $barWidth * 8) / $total))}]
-
- set barInteger [expr {$barProgress / 8}]
- #set barRemainder [expr {$barProgress % 8}]
-
- # Finally, also provide a percentage value to print behind the progress bar
- set percentage [expr {double($current) * 100 / double($total)}]
-
- # clear the current line, enable reverse video
- set progressbar "\033\[7m"
- for {set i 0} {$i < $barInteger} {incr i} {
- # U+2588 FULL BLOCK doesn't match the other blocks in some fonts :/
- # Two half blocks work better in some fonts, but not in others (because
- # they leave ugly spaces). So, one or the other choice isn't better or
- # worse and even just using full blocks looks ugly in a few fonts.
-
- # Use pure ASCII until somebody fixes most of the default terminal fonts :/
- append progressbar " "
- }
- # back to normal output
- append progressbar "\033\[0m"
-
- #switch $barRemainder {
- # 0 {
- # if {$barInteger < $barWidth} {
- # append progressbar " "
- # }
- # }
- # 1 {
- # # U+258F LEFT ONE EIGHTH BLOCK
- # append progressbar "\u258f"
- # }
- # 2 {
- # # U+258E LEFT ONE QUARTER BLOCK
- # append progressbar "\u258e"
- # }
- # 3 {
- # # U+258D LEFT THREE EIGHTHS BLOCK
- # append progressbar "\u258d"
- # }
- # 3 {
- # # U+258D LEFT THREE EIGHTHS BLOCK
- # append progressbar "\u258d"
- # }
- # 4 {
- # # U+258C LEFT HALF BLOCK
- # append progressbar "\u258c"
- # }
- # 5 {
- # # U+258B LEFT FIVE EIGHTHS BLOCK
- # append progressbar "\u258b"
- # }
- # 6 {
- # # U+258A LEFT THREE QUARTERS BLOCK
- # append progressbar "\u258a"
- # }
- # 7 {
- # # U+2589 LEFT SEVEN EIGHTHS BLOCK
- # append progressbar "\u2589"
- # }
- #}
-
- # Fill the progress bar with spaces
- for {set i $barInteger} {$i < $barWidth} {incr i} {
- append progressbar " "
- }
-
- # Format the percentage using the space that has been reserved for it
- set percentagesuffix [format " %[expr {$percentageWidth - 3}].1f %%" $percentage]
-
- puts -nonewline "\r${prefix}\[${progressbar}\]${percentagesuffix}${suffix}"
- flush stdout
- }
-
-
- ##
- # Internal state of the progress indicator; unless you're hacking the
- # unprogressbar code you should never touch this.
- variable unprogressState 0
-
- ##
- # Draw a progress indicator
- #
- # @param width
- # The width in characters of the progress indicator.
- # @param prefix
- # Prefix to be printed in front of the progress indicator.
- # @param suffix
- # Suffix to be printed after the progress indicator.
- proc unprogressbar {width {prefix ""} {suffix ""}} {
- variable unprogressState
-
- # Subtract the two characters [ and ] bounding the progress indicator
- # from the width.
- set barWidth [expr {int($width) - 2}]
-
- # Number of states of the progress bar, or rather: the number of
- # characters before the sequence repeats.
- set numStates 4
-
- set unprogressState [expr {($unprogressState + 1) % $numStates}]
-
- set progressbar ""
- for {set i 0} {$i < $barWidth} {incr i} {
- if {[expr {$i % $numStates}] == $unprogressState} {
- # U+2022 BULLET
- append progressbar "\u2022"
- } else {
- append progressbar " "
- }
- }
-
- puts -nonewline "\r${prefix}\[${progressbar}\]${suffix}"
- flush stdout
- }
-}
-
-namespace eval portclient::notifications {
- ##
- # Ports whose notifications to display; these were either installed
- # or requested to be installed.
- variable notificationsToPrint
- array set notificationsToPrint {}
-
- ##
- # Add a port to the list for printing notifications.
- #
- # @param name
- # The name of the port.
- # @param note
- # A list of notes to be stored for the given port.
- proc append {name notes} {
- variable notificationsToPrint
-
- set notificationsToPrint($name) $notes
- }
-
- ##
- # Print port notifications.
- #
- proc display {} {
- global env
- variable notificationsToPrint
-
- # Display notes at the end of the activation phase.
- if {[array size notificationsToPrint] > 0} {
- ui_notice "---> Some of the ports you installed have notes:"
- foreach {name notes} [array get notificationsToPrint] {
- ui_notice " $name has the following notes:"
-
- # If env(COLUMNS) exists, limit each line's width to this width.
- if {[info exists env(COLUMNS)]} {
- set maxlen $env(COLUMNS)
-
- foreach note $notes {
- foreach line [split $note "\n"] {
- set joiner ""
- set lines ""
- set newline " "
-
- foreach word [split $line " "] {
- if {[string length $newline] + [string length $word] >= $maxlen} {
- lappend lines $newline
- set newline " "
- set joiner ""
- }
- ::append newline $joiner $word
- set joiner " "
- }
- if {$newline ne {}} {
- lappend lines $newline
- }
- ui_notice [join $lines "\n"]
- }
- }
- } else {
- foreach note $notes {
- ui_notice $note
- }
- }
- }
- }
- }
-}
-
-
-##########################################
-# Main
-##########################################
-
-# Global arrays passed to the macports1.0 layer
-array set ui_options {}
-array set global_options {}
-array set global_variations {}
-
-# Global options private to this script
-array set private_options {}
-
-# Make sure we get the size of the terminal
-# We do this here to save it in the boot_env, in case we determined it manually
-term_init_size
-
-global env boot_env argv0 cmdname argc argv cmd_argc cmd_argv cmd_argn \
- current_portdir global_options_base exit_status
-
-# Save off a copy of the environment before mportinit monkeys with it
-array set boot_env [array get env]
-
-set cmdname [file tail $argv0]
-
-# Setp cmd_argv to match argv
-set cmd_argv $argv
-set cmd_argc $argc
-set cmd_argn 0
-
-# make sure we're using a sane umask
-umask 022
-
-# If we've been invoked as portf, then the first argument is assumed
-# to be the name of a command file (i.e., there is an implicit -F
-# before any arguments).
-if {[moreargs] && $cmdname eq "portf"} {
- lappend ui_options(ports_commandfiles) [lookahead]
- advance
-}
-
-# Parse global options that will affect all subsequent commands
-if {[catch {parse_options "global" ui_options global_options} result]} {
- puts "Error: $result"
- print_usage
- exit 1
-}
-
-if {[isatty stdout]
- && $portclient::progress::hasTermAnsiSend eq "yes"
- && (![info exists ui_options(ports_quiet)] || $ui_options(ports_quiet) ne "yes")} {
- set ui_options(progress_download) portclient::progress::download
- set ui_options(progress_generic) portclient::progress::generic
-}
-
-set ui_options(notifications_append) portclient::notifications::append
-
-# Get arguments remaining after option processing
-set remaining_args [lrange $cmd_argv $cmd_argn end]
-
-# If we have no arguments remaining after option processing then force
-# interactive mode
-if { [llength $remaining_args] == 0 && ![info exists ui_options(ports_commandfiles)] } {
- lappend ui_options(ports_commandfiles) -
-} elseif {[lookahead] eq "selfupdate" || [lookahead] eq "sync"} {
- # tell mportinit not to tell the user they should selfupdate
- set ui_options(ports_no_old_index_warning) 1
-}
-
-# Initialize mport
-# This must be done following parse of global options, as some options are
-# evaluated by mportinit.
-if {[catch {mportinit ui_options global_options global_variations} result]} {
- global errorInfo
- puts "$errorInfo"
- fatal "Failed to initialize MacPorts, $result"
-}
-
-# Set up some global state for our code
-set current_portdir [pwd]
-
-# Freeze global_options into global_options_base; global_options
-# will be reset to global_options_base prior to processing each command.
-set global_options_base [array get global_options]
-
-# First process any remaining args as action(s)
-set exit_status 0
-if { [llength $remaining_args] > 0 } {
-
- # If there are remaining arguments, process those as a command
- set exit_status [process_cmd $remaining_args]
-}
-
-# Process any prescribed command files, including standard input
-if { ($exit_status == 0 || [macports::ui_isset ports_processall]) && [info exists ui_options(ports_commandfiles)] } {
- set exit_status [process_command_files $ui_options(ports_commandfiles)]
-}
-if {$exit_status == -999} {
- set exit_status 0
-}
-
-# shut down macports1.0
-mportshutdown
-
-# Return with exit_status
-exit $exit_status
Deleted: branches/gsoc14-cleanup/src/port/port.BASE.23878
===================================================================
--- branches/gsoc14-cleanup/src/port/port.BASE.23878 2014-08-13 22:14:51 UTC (rev 123747)
+++ branches/gsoc14-cleanup/src/port/port.BASE.23878 2014-08-13 22:14:53 UTC (rev 123748)
@@ -1,5343 +0,0 @@
-#!/opt/local/libexec/macports/bin/tclsh8.5
-# -*- coding: utf-8; mode: tcl; tab-width: 4; indent-tabs-mode: nil; c-basic-offset: 4 -*- vim:fenc=utf-8:filetype=tcl:et:sw=4:ts=4:sts=4
-# $Id: port.tcl 119177 2014-04-18 22:35:29Z cal at macports.org $
-#
-# Copyright (c) 2004-2014 The MacPorts Project
-# Copyright (c) 2004 Robert Shaw <rshaw at opendarwin.org>
-# Copyright (c) 2002-2003 Apple 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 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.
-
-# Create a namespace for some local variables
-namespace eval portclient::progress {
- ##
- # Indicate whether the term::ansi::send tcllib package is available and was
- # imported. "yes", if the package is available, "no" otherwise.
- variable hasTermAnsiSend no
-}
-
-if {![catch {package require term::ansi::send}]} {
- set portclient::progress::hasTermAnsiSend yes
-}
-
-package require macports
-package require reclaim 1.0
-package require Pextlib 1.0
-
-# Standard procedures
-proc print_usage {{verbose 1}} {
- global cmdname
- set syntax {
- [-bcdfknopqRstuvy] [-D portdir] [-F cmdfile] action [privopts] [actionflags]
- [[portname|pseudo-portname|port-url] [@version] [+-variant]... [option=value]...]...
- }
-
- if {$verbose} {
- puts stderr "Usage: $cmdname$syntax"
- puts stderr "\"$cmdname help\" or \"man 1 port\" for more information."
- } else {
- puts stderr "$cmdname$syntax"
- }
-}
-
-proc print_help {args} {
- global action_array
-
- print_usage 0
-
- # Generate and format the command list from the action_array
- set cmds ""
- set lineLen 0
- foreach cmd [lsort [array names action_array]] {
- if {$lineLen > 65} {
- set cmds "$cmds,\n"
- set lineLen 0
- }
- if {$lineLen == 0} {
- set new "$cmd"
- } else {
- set new ", $cmd"
- }
- incr lineLen [string length $new]
- set cmds "$cmds$new"
- }
-
- set cmdText "Supported actions
-------------------
-$cmds
-"
-
- set text {
-Pseudo-portnames
-----------------
-Pseudo-portnames are words that may be used in place of a portname, and
-which expand to some set of ports. The common pseudo-portnames are:
-all, current, active, inactive, actinact, installed, uninstalled, outdated,
-obsolete, requested, unrequested and leaves.
-These pseudo-portnames expand to the set of ports named.
-
-Pseudo-portnames starting with variants:, variant:, description:, depends:,
-depends_lib:, depends_run:, depends_build:, depends_fetch:, depends_extract:,
-portdir:, homepage:, epoch:, platforms:, platform:, name:, long_description:,
-maintainers:, maintainer:, categories:, category:, version:, revision:, and
-license: each select a set of ports based on a regex search of metadata
-about the ports. In all such cases, a standard regex pattern following
-the colon will be used to select the set of ports to which the
-pseudo-portname expands.
-
-Pseudo-portnames starting with depof:, rdepof:, dependentof:, and rdependentof:
-select ports that are direct or recursive dependencies or dependents of the
-following portname, respectively.
-
-Portnames that contain standard glob characters will be expanded to the
-set of ports matching the glob pattern.
-
-Port expressions
-----------------
-Portnames, port glob patterns, and pseudo-portnames may be logically
-combined using expressions consisting of and, or, not, !, (, and ).
-
-For more information
---------------------
-See man pages: port(1), macports.conf(5), portfile(7), portgroup(7),
-porthier(7), portstyle(7). Also, see http://www.macports.org.
- }
-
- puts "$cmdText$text"
-}
-
-
-# Produce error message and exit
-proc fatal s {
- global argv0
- ui_error "$argv0: $s"
- exit 1
-}
-
-##
-# Helper function to define constants
-#
-# Constants defined with const can simply be accessed in the same way as
-# calling a proc.
-#
-# Example:
-# const FOO 42
-# puts [FOO]
-#
-# @param name variable name
-# @param value constant variable value
-proc const {name args} {
- proc $name {} [list return [expr $args]]
-}
-
-# Format an integer representing bytes using given units
-proc bytesize {siz {unit {}} {format {%.3f}}} {
- if {$unit == {}} {
- if {$siz > 0x40000000} {
- set unit "GiB"
- } elseif {$siz > 0x100000} {
- set unit "MiB"
- } elseif {$siz > 0x400} {
- set unit "KiB"
- } else {
- set unit "B"
- }
- }
- switch -- $unit {
- KiB {
- set siz [expr {$siz / 1024.0}]
- }
- kB {
- set siz [expr {$siz / 1000.0}]
- }
- MiB {
- set siz [expr {$siz / 1048576.0}]
- }
- MB {
- set siz [expr {$siz / 1000000.0}]
- }
- GiB {
- set siz [expr {$siz / 1073741824.0}]
- }
- GB {
- set siz [expr {$siz / 1000000000.0}]
- }
- B { }
- default {
- ui_warn "Unknown file size unit '$unit' specified"
- set unit "B"
- }
- }
- if {[expr {round($siz)}] != $siz} {
- set siz [format $format $siz]
- }
- return "$siz $unit"
-}
-
-proc filesize {fil {unit {}}} {
- set siz {@}
- catch {
- set siz [bytesize [file size $fil] $unit]
- }
- return $siz
-}
-
-# Produce an error message, and exit, unless
-# we're handling errors in a soft fashion, in which
-# case we continue
-proc fatal_softcontinue s {
- if {[macports::global_option_isset ports_force]} {
- ui_error $s
- return -code continue
- } else {
- fatal $s
- }
-}
-
-
-# Produce an error message, and break, unless
-# we're handling errors in a soft fashion, in which
-# case we continue
-proc break_softcontinue { msg status name_status } {
- upvar $name_status status_var
- ui_error $msg
- if {[macports::ui_isset ports_processall]} {
- set status_var 0
- return -code continue
- } else {
- set status_var $status
- return -code break
- }
-}
-
-# show the URL for the ticket reporting instructions
-proc print_tickets_url {args} {
- if {${macports::prefix} ne "/usr/local" && ${macports::prefix} ne "/usr"} {
- ui_error "Follow http://guide.macports.org/#project.tickets to report a bug."
- }
-}
-
-# Form a composite version as is sometimes used for registry functions
-# This function sorts the variants and presents them in a canonical representation
-proc composite_version {version variations {emptyVersionOkay 0}} {
- # Form a composite version out of the version and variations
-
- # Select the variations into positive and negative
- set pos {}
- set neg {}
- foreach { key val } $variations {
- if {$val eq "+"} {
- lappend pos $key
- } elseif {$val eq "-"} {
- lappend neg $key
- }
- }
-
- # If there is no version, we have nothing to do
- set composite_version ""
- if {$version ne "" || $emptyVersionOkay} {
- set pos_str ""
- set neg_str ""
-
- if {[llength $pos]} {
- set pos_str "+[join [lsort -ascii $pos] "+"]"
- }
- if {[llength $neg]} {
- set neg_str "-[join [lsort -ascii $neg] "-"]"
- }
-
- set composite_version "$version$pos_str$neg_str"
- }
-
- return $composite_version
-}
-
-
-proc split_variants {variants} {
- set result {}
- set l [regexp -all -inline -- {([-+])([[:alpha:]_]+[\w\.]*)} $variants]
- foreach { match sign variant } $l {
- lappend result $variant $sign
- }
- return $result
-}
-
-
-##
-# Maps friendly field names to their real name
-# Names which do not need mapping are not changed.
-#
-# @param field friendly name
-# @return real name
-proc map_friendly_field_names { field } {
- switch -- $field {
- variant -
- platform -
- maintainer -
- subport {
- set field "${field}s"
- }
- category {
- set field "categories"
- }
- }
-
- return $field
-}
-
-
-proc registry_installed {portname {portversion ""}} {
- set ilist [registry::installed $portname $portversion]
- if { [llength $ilist] > 1 } {
- # set portname again since the one we were passed may not have had the correct case
- set portname [lindex $ilist 0 0]
- ui_notice "The following versions of $portname are currently installed:"
- foreach i [portlist_sortint $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 -code error "Registry error: Please specify the full version as recorded in the port registry."
- } else {
- return [lindex $ilist 0]
- }
-}
-
-
-proc entry_for_portlist {portentry} {
- global global_options global_variations
-
- # Each portlist entry currently has the following elements in it:
- # url if any
- # name
- # version (version_revision)
- # variants array (variant=>+-)
- # requested_variants array (variant=>+-)
- # options array (key=>value)
- # fullname (name/version_revision+-variants)
-
- array set port $portentry
- if {![info exists port(url)]} { set port(url) "" }
- if {![info exists port(name)]} { set port(name) "" }
- if {![info exists port(version)]} { set port(version) "" }
- if {![info exists port(variants)]} { set port(variants) "" }
- if {![info exists port(requested_variants)]} { set port(requested_variants) "" }
- if {![info exists port(options)]} { set port(options) [array get global_options] }
-
- # If neither portname nor url is specified, then default to the current port
- if { $port(url) eq "" && $port(name) eq "" } {
- set url file://.
- set portname [url_to_portname $url]
- set port(url) $url
- set port(name) $portname
- if {$portname eq ""} {
- ui_error "A default port name could not be supplied."
- }
- }
-
- # Form the fully discriminated portname: portname/version_revison+-variants
- set port(fullname) "$port(name)/[composite_version $port(version) $port(variants)]"
-
- return [array get port]
-}
-
-
-proc add_to_portlist {listname portentry} {
- upvar $listname portlist
-
- # Form portlist entry and add to portlist
- lappend portlist [entry_for_portlist $portentry]
-}
-
-
-proc add_ports_to_portlist {listname ports {overridelist ""}} {
- upvar $listname portlist
-
- array set overrides $overridelist
-
- # Add each entry to the named portlist, overriding any values
- # specified as overrides
- foreach portentry $ports {
- array set port $portentry
- if ([info exists overrides(version)]) { set port(version) $overrides(version) }
- if ([info exists overrides(variants)]) { set port(variants) $overrides(variants) }
- if ([info exists overrides(requested_variants)]) { set port(requested_variants) $overrides(requested_variants) }
- if ([info exists overrides(options)]) { set port(options) $overrides(options) }
- add_to_portlist portlist [array get port]
- }
-}
-
-
-proc url_to_portname { url {quiet 0} } {
- # Save directory and restore the directory, since mportopen changes it
- set savedir [pwd]
- set portname ""
- if {[catch {set ctx [mportopen $url]} result]} {
- if {!$quiet} {
- ui_msg "Can't map the URL '$url' to a port description file (\"${result}\")."
- ui_msg "Please verify that the directory and portfile syntax are correct."
- }
- } else {
- array set portinfo [mportinfo $ctx]
- set portname $portinfo(name)
- mportclose $ctx
- }
- cd $savedir
- return $portname
-}
-
-
-# Supply a default porturl/portname if the portlist is empty
-proc require_portlist { nameportlist {is_upgrade "no"} } {
- global private_options
- upvar $nameportlist portlist
-
- if {[llength $portlist] == 0 && (![info exists private_options(ports_no_args)] || $private_options(ports_no_args) eq "no")} {
- if {${is_upgrade} == "yes"} {
- # $> port upgrade outdated
- # Error: No ports matched the given expression
- # is not very user friendly - if we're in the special case of
- # "upgrade", let's print a message that's a little easier to
- # understand and less alarming.
- ui_msg "Nothing to upgrade."
- return 1
- }
- ui_error "No ports matched the given expression"
- return 1
- }
-
- if {[llength $portlist] == 0} {
- set portlist [get_current_port]
-
- if {[llength $portlist] == 0} {
- # there was no port in current directory
- return 1
- }
- }
-
- return 0
-}
-
-
-# Execute the enclosed block once for every element in the portlist
-# When the block is entered, the following variables will have been set:
-# portspec, porturl, portname, portversion, options, variations, requested_variations
-proc foreachport {portlist block} {
- set savedir [pwd]
- foreach portspec $portlist {
-
- # Set the variables for the block
- uplevel 1 "array unset portspec; array set portspec { $portspec }"
- uplevel 1 {
- set porturl $portspec(url)
- set portname $portspec(name)
- set portversion $portspec(version)
- array unset variations
- array set variations $portspec(variants)
- array unset requested_variations
- array set requested_variations $portspec(requested_variants)
- array unset options
- array set options $portspec(options)
- }
-
- # Invoke block
- uplevel 1 $block
-
- # Restore cwd after each port, since mportopen changes it, and otherwise relative
- # urls would break on subsequent passes
- if {[file exists $savedir]} {
- cd $savedir
- } else {
- cd ~
- }
- }
-}
-
-
-proc portlist_compare { a b } {
- array set a_ $a
- array set b_ $b
- set namecmp [string equal -nocase $a_(name) $b_(name)]
- if {$namecmp != 1} {
- if {$a_(name) eq [lindex [lsort -dictionary [list $a_(name) $b_(name)]] 0]} {
- return -1
- }
- return 1
- }
- set avr_ [split $a_(version) "_"]
- set bvr_ [split $b_(version) "_"]
- set versioncmp [vercmp [lindex $avr_ 0] [lindex $bvr_ 0]]
- if {$versioncmp != 0} {
- return $versioncmp
- }
- set ar_ [lindex $avr_ 1]
- set br_ [lindex $bvr_ 1]
- if {$ar_ < $br_} {
- return -1
- } elseif {$ar_ > $br_} {
- return 1
- } else {
- return 0
- }
-}
-
-# Sort two ports in NVR (name at version_revision) order
-proc portlist_sort { list } {
- return [lsort -command portlist_compare $list]
-}
-
-proc portlist_compareint { a b } {
- array set a_ [list "name" [lindex $a 0] "version" "[lindex $a 1]_[lindex $a 2]"]
- array set b_ [list "name" [lindex $b 0] "version" "[lindex $b 1]_[lindex $b 2]"]
- return [portlist_compare [array get a_] [array get b_]]
-}
-
-# Same as portlist_sort, but with numeric indexes {name version revision}
-proc portlist_sortint { list } {
- return [lsort -command portlist_compareint $list]
-}
-
-# sort portlist so dependents come before their dependencies
-proc portlist_sortdependents { portlist } {
- foreach p $portlist {
- array set pvals $p
- lappend entries($pvals(name)) $p
- if {![info exists dependents($pvals(name))]} {
- set dependents($pvals(name)) {}
- foreach result [registry::list_dependents $pvals(name)] {
- lappend dependents($pvals(name)) [lindex $result 2]
- }
- }
- array unset pvals
- }
- set ret {}
- foreach p $portlist {
- portlist_sortdependents_helper $p entries dependents seen ret
- }
- return $ret
-}
-
-proc portlist_sortdependents_helper {p up_entries up_dependents up_seen up_retlist} {
- upvar $up_seen seen
- if {![info exists seen($p)]} {
- set seen($p) 1
- upvar $up_entries entries $up_dependents dependents $up_retlist retlist
- array set pvals $p
- foreach dependent $dependents($pvals(name)) {
- if {[info exists entries($dependent)]} {
- foreach entry $entries($dependent) {
- portlist_sortdependents_helper $entry entries dependents seen retlist
- }
- }
- }
- lappend retlist $p
- }
-}
-
-proc regex_pat_sanitize { s } {
- set sanitized [regsub -all {[\\(){}+$.^]} $s {\\&}]
- return $sanitized
-}
-
-##
-# Makes sure we get the current terminal size
-proc term_init_size {} {
- global env
-
- if {![info exists env(COLUMNS)] || ![info exists env(LINES)]} {
- if {[isatty stdout]} {
- set size [term_get_size stdout]
-
- if {![info exists env(LINES)] && [lindex $size 0] > 0} {
- set env(LINES) [lindex $size 0]
- }
-
- if {![info exists env(COLUMNS)] && [lindex $size 1] > 0} {
- set env(COLUMNS) [lindex $size 1]
- }
- }
- }
-}
-
-##
-# Wraps a multi-line string at specified textwidth
-#
-# @see wrapline
-#
-# @param string input string
-# @param maxlen text width (0 defaults to current terminal width)
-# @param indent prepend to every line
-# @return wrapped string
-proc wrap {string maxlen {indent ""} {indentfirstline 1}} {
- global env
-
- if {$maxlen == 0} {
- if {![info exists env(COLUMNS)]} {
- # no width for wrapping
- return $string
- }
- set maxlen $env(COLUMNS)
- }
-
- set splitstring {}
- set indentline $indentfirstline
- foreach line [split $string "\n"] {
- lappend splitstring [wrapline $line $maxlen $indent $indentline]
- set indentline 1
- }
- return [join $splitstring "\n"]
-}
-
-##
-# Wraps a line at specified textwidth
-#
-# @see wrap
-#
-# @param line input line
-# @param maxlen text width (0 defaults to current terminal width)
-# @param indent prepend to every line
-# @return wrapped string
-proc wrapline {line maxlen {indent ""} {indentfirstline 1}} {
- global env
-
- if {$maxlen == 0} {
- if {![info exists env(COLUMNS)]} {
- # no width for wrapping
- return $string
- }
- set maxlen $env(COLUMNS)
- }
-
- set string [split $line " "]
- if {$indentfirstline == 0} {
- set newline ""
- set maxlen [expr {$maxlen - [string length $indent]}]
- } else {
- set newline $indent
- }
- append newline [lindex $string 0]
- set joiner " "
- set first 1
- foreach word [lrange $string 1 end] {
- if {[string length $newline]+[string length $word] >= $maxlen} {
- lappend lines $newline
- set newline $indent
- set joiner ""
- # If indentfirstline is set to 0, reset maxlen to its
- # original length after appending the first line to lines.
- if {$first == 1 && $indentfirstline == 0} {
- set maxlen [expr {$maxlen + [string length $indent]}]
- }
- set first 0
- }
- append newline $joiner $word
- set joiner " "
- }
- lappend lines $newline
- return [join $lines "\n"]
-}
-
-##
-# Wraps a line at a specified width with a label in front
-#
-# @see wrap
-#
-# @param label label for output
-# @param string input string
-# @param maxlen text width (0 defaults to current terminal width)
-# @return wrapped string
-proc wraplabel {label string maxlen {indent ""}} {
- append label ": [string repeat " " [expr {[string length $indent] - [string length "$label: "]}]]"
- return "$label[wrap $string $maxlen $indent 0]"
-}
-
-proc unobscure_maintainers { list } {
- set result {}
- foreach m $list {
- if {[string first "@" $m] < 0} {
- if {[string first ":" $m] >= 0} {
- set m [regsub -- "(.*):(.*)" $m "\\2@\\1"]
- } else {
- set m "$m at macports.org"
- }
- }
- lappend result $m
- }
- return $result
-}
-
-
-##########################################
-# Port selection
-##########################################
-proc unique_results_to_portlist {infos} {
- set result {}
- array unset unique
- foreach {name info} $infos {
- array unset portinfo
- array set portinfo $info
-
- set portentry [entry_for_portlist [list url $portinfo(porturl) name $name]]
-
- array unset entry
- array set entry $portentry
-
- if {[info exists unique($entry(fullname))]} continue
- set unique($entry(fullname)) 1
-
- lappend result $portentry
- }
- return $result
-}
-
-
-proc get_matching_ports {pattern {casesensitive no} {matchstyle glob} {field name}} {
- if {[catch {set res [mportsearch $pattern $casesensitive $matchstyle $field]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "search for portname $pattern failed: $result"
- }
- set results [unique_results_to_portlist $res]
-
- # Return the list of all ports, sorted
- return [portlist_sort $results]
-}
-
-
-proc get_all_ports {} {
- global all_ports_cache
-
- if {![info exists all_ports_cache]} {
- if {[catch {set res [mportlistall]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "listing all ports failed: $result"
- }
- set results [unique_results_to_portlist $res]
- set all_ports_cache [portlist_sort $results]
- }
- return $all_ports_cache
-}
-
-
-proc get_current_ports {} {
- # This is just a synonym for get_current_port that
- # works with the regex in element
- return [get_current_port]
-}
-
-
-proc get_current_port {} {
- set url file://.
- set portname [url_to_portname $url]
- if {$portname eq ""} {
- ui_msg "To use the current port, you must be in a port's directory."
- return [list]
- }
-
- set results {}
- add_to_portlist results [list url $url name $portname]
- return $results
-}
-
-
-proc get_installed_ports { {ignore_active yes} {active yes} } {
- set ilist {}
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "port installed failed: $result"
- }
- }
-
- set results {}
- foreach i $ilist {
- set iname [lindex $i 0]
- set iversion [lindex $i 1]
- set irevision [lindex $i 2]
- set ivariants [split_variants [lindex $i 3]]
- set iactive [lindex $i 4]
-
- if { ${ignore_active} == "yes" || (${active} == "yes") == (${iactive} != 0) } {
- add_to_portlist results [list name $iname version "${iversion}_${irevision}" variants $ivariants]
- }
- }
-
- # Return the list of ports, sorted
- return [portlist_sort $results]
-}
-
-
-proc get_uninstalled_ports {} {
- # Return all - installed
- set all [get_all_ports]
- set installed [get_installed_ports]
- return [opComplement $all $installed]
-}
-
-
-proc get_active_ports {} {
- return [get_installed_ports no yes]
-}
-
-
-proc get_inactive_ports {} {
- return [get_installed_ports no no]
-}
-
-proc get_actinact_ports {} {
- set inactive_ports [get_inactive_ports]
- set active_ports [get_active_ports]
- set results {}
-
- foreach port $inactive_ports {
- array set portspec $port
- set portname $portspec(name)
- lappend inact($portname) $port
- }
-
- foreach port $active_ports {
- array set portspec $port
- set portname $portspec(name)
-
- if {[info exists inact($portname)]} {
- if {![info exists added_inact($portname)]} {
- foreach inact_spec $inact($portname) {
- lappend results $inact_spec
- }
- set added_inact($portname) 1
- }
- lappend results $port
- }
- }
- return $results
-}
-
-
-proc get_outdated_ports {} {
- # Get the list of installed ports
- set ilist {}
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "port installed failed: $result"
- }
- }
-
- # Now process the list, keeping only those ports that are outdated
- set results {}
- if { [llength $ilist] > 0 } {
- foreach i $ilist {
-
- # Get information about the installed port
- set portname [lindex $i 0]
- set installed_version [lindex $i 1]
- set installed_revision [lindex $i 2]
- set installed_compound "${installed_version}_${installed_revision}"
- set installed_variants [lindex $i 3]
-
- set is_active [lindex $i 4]
- if {$is_active == 0} continue
-
- set installed_epoch [lindex $i 5]
-
- # Get info about the port from the index
- if {[catch {set res [mportlookup $portname]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "lookup of portname $portname failed: $result"
- }
- if {[llength $res] < 2} {
- if {[macports::ui_isset ports_debug]} {
- puts stderr "$portname ($installed_compound is installed; the port was not found in the port index)"
- }
- continue
- }
- array unset portinfo
- array set portinfo [lindex $res 1]
-
- # Get information about latest available version and revision
- set latest_version $portinfo(version)
- set latest_revision 0
- if {[info exists portinfo(revision)] && $portinfo(revision) > 0} {
- set latest_revision $portinfo(revision)
- }
- set latest_compound "${latest_version}_${latest_revision}"
- set latest_epoch 0
- if {[info exists portinfo(epoch)]} {
- set latest_epoch $portinfo(epoch)
- }
-
- # Compare versions, first checking epoch, then version, then revision
- set comp_result 0
- if {$installed_version != $latest_version} {
- set comp_result [expr {$installed_epoch - $latest_epoch}]
- if { $comp_result == 0 } {
- set comp_result [vercmp $installed_version $latest_version]
- }
- }
- if { $comp_result == 0 } {
- set comp_result [expr {$installed_revision - $latest_revision}]
- }
- if {$comp_result == 0} {
- set regref [registry::open_entry $portname $installed_version $installed_revision $installed_variants $installed_epoch]
- set os_platform_installed [registry::property_retrieve $regref os_platform]
- set os_major_installed [registry::property_retrieve $regref os_major]
- if {$os_platform_installed ne "" && $os_platform_installed != 0
- && $os_major_installed ne "" && $os_major_installed != 0
- && ($os_platform_installed != ${macports::os_platform} || $os_major_installed != ${macports::os_major})} {
- set comp_result -1
- }
- }
-
- # Add outdated ports to our results list
- if { $comp_result < 0 } {
- add_to_portlist results [list name $portname version $installed_compound variants [split_variants $installed_variants]]
- }
- }
- }
-
- return [portlist_sort $results]
-}
-
-
-proc get_obsolete_ports {} {
- set ilist [get_installed_ports]
- set results {}
-
- foreach i $ilist {
- array set port $i
-
- if {[catch {mportlookup $port(name)} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
-
- if {[llength $result] < 2} {
- lappend results $i
- }
- }
-
- # Return the list of ports, already sorted
- return [portlist_sort $results]
-}
-
-# return ports that have registry property $propname set to $propval
-proc get_ports_with_prop {propname propval} {
- set ilist {}
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "port installed failed: $result"
- }
- }
-
- set results {}
- foreach i $ilist {
- set iname [lindex $i 0]
- set iversion [lindex $i 1]
- set irevision [lindex $i 2]
- set ivariants [lindex $i 3]
- set iepoch [lindex $i 5]
- set regref [registry::open_entry $iname $iversion $irevision $ivariants $iepoch]
- if {[registry::property_retrieve $regref $propname] == $propval} {
- add_to_portlist results [list name $iname version "${iversion}_${irevision}" variants [split_variants $ivariants]]
- }
- }
-
- # Return the list of ports, sorted
- return [portlist_sort $results]
-}
-
-proc get_requested_ports {} {
- return [get_ports_with_prop requested 1]
-}
-
-proc get_unrequested_ports {} {
- return [get_ports_with_prop requested 0]
-}
-
-proc get_leaves_ports {} {
- set ilist {}
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "port installed failed: $result"
- }
- }
- registry::open_dep_map
- set results {}
- foreach i $ilist {
- set iname [lindex $i 0]
- if {[registry::list_dependents $iname] eq ""} {
- add_to_portlist results [list name $iname version "[lindex $i 1]_[lindex $i 2]" variants [split_variants [lindex $i 3]]]
- }
- }
- return [portlist_sort [opIntersection $results [get_unrequested_ports]]]
-}
-
-proc get_dependent_ports {portname recursive} {
- registry::open_dep_map
- set deplist [registry::list_dependents $portname]
- # could return specific versions here using registry2.0 features
- set results {}
- foreach dep $deplist {
- add_to_portlist results [list name [lindex $dep 2]]
- }
-
- # actually do this iteratively to avoid hitting Tcl's recursion limit
- if {$recursive} {
- while 1 {
- set rportlist {}
- set newlist {}
- foreach dep $deplist {
- set depname [lindex $dep 2]
- if {![info exists seen($depname)]} {
- set seen($depname) 1
- set rdeplist [registry::list_dependents $depname]
- foreach rdep $rdeplist {
- lappend newlist $rdep
- add_to_portlist rportlist [list name [lindex $rdep 2]]
- }
- }
- }
- if {[llength $rportlist] > 0} {
- set results [opUnion $results $rportlist]
- set deplist $newlist
- } else {
- break
- }
- }
- }
-
- return [portlist_sort $results]
-}
-
-
-proc get_dep_ports {portname recursive} {
- global global_variations
-
- # look up portname
- if {[catch {mportlookup $portname} result]} {
- ui_debug "$::errorInfo"
- return -code error "lookup of portname $portname failed: $result"
- }
- if {[llength $result] < 2} {
- return -code error "Port $portname not found"
- }
- array unset portinfo
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
-
- # open portfile
- if {[catch {set mport [mportopen $porturl [list subport $portinfo(name)] [array get global_variations]]} result]} {
- ui_debug "$::errorInfo"
- return -code error "Unable to open port: $result"
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
-
- # gather its deps
- set results {}
- set deptypes {depends_fetch depends_extract depends_build depends_lib depends_run}
-
- set deplist {}
- foreach type $deptypes {
- if {[info exists portinfo($type)]} {
- foreach dep $portinfo($type) {
- add_to_portlist results [list name [lindex [split $dep :] end]]
- lappend deplist $dep
- }
- }
- }
-
- # actually do this iteratively to avoid hitting Tcl's recursion limit
- if {$recursive} {
- while 1 {
- set rportlist {}
- set newlist {}
- foreach dep $deplist {
- set depname [lindex [split $dep :] end]
- if {![info exists seen($depname)]} {
- set seen($depname) 1
-
- # look up the dep
- if {[catch {mportlookup $depname} result]} {
- ui_debug "$::errorInfo"
- return -code error "lookup of portname $depname failed: $result"
- }
- if {[llength $result] < 2} {
- ui_error "Port $depname not found"
- continue
- }
- array unset portinfo
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
-
- # open its portfile
- if {[catch {set mport [mportopen $porturl [list subport $portinfo(name)] [array get global_variations]]} result]} {
- ui_debug "$::errorInfo"
- ui_error "Unable to open port: $result"
- continue
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
-
- # collect its deps
- set rdeplist {}
- foreach type $deptypes {
- if {[info exists portinfo($type)]} {
- foreach rdep $portinfo($type) {
- add_to_portlist results [list name [lindex [split $rdep :] end]]
- lappend rdeplist $rdep
- }
- }
- }
-
- # add them to the lists
- foreach rdep $rdeplist {
- lappend newlist $rdep
- add_to_portlist rportlist [list name [lindex [split $rdep :] end]]
- }
- }
- }
- if {[llength $rportlist] > 0} {
- set results [opUnion $results $rportlist]
- set deplist $newlist
- } else {
- break
- }
- }
- }
-
- return [portlist_sort $results]
-}
-
-proc get_subports {portname} {
- global global_variations
-
- # look up portname
- if {[catch {mportlookup $portname} result]} {
- ui_debug "$::errorInfo"
- return -code error "lookup of portname $portname failed: $result"
- }
- if {[llength $result] < 2} {
- return -code error "Port $portname not found"
- }
- array unset portinfo
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
-
- # open portfile
- if {[catch {set mport [mportopen $porturl [list subport $portinfo(name)] [array get global_variations]]} result]} {
- ui_debug "$::errorInfo"
- return -code error "Unable to open port: $result"
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
-
- # gather its subports
- set results {}
-
- if {[info exists portinfo(subports)]} {
- foreach subport $portinfo(subports) {
- add_to_portlist results [list name $subport]
- }
- }
-
- return [portlist_sort $results]
-}
-
-
-##########################################
-# Port expressions
-##########################################
-proc portExpr { resname } {
- upvar $resname reslist
- set result [seqExpr reslist]
- return $result
-}
-
-
-proc seqExpr { resname } {
- upvar $resname reslist
-
- # Evaluate a sequence of expressions a b c...
- # These act the same as a or b or c
-
- set result 1
- while {$result} {
- switch -- [lookahead] {
- ; -
- ) -
- _EOF_ { break }
- }
-
- set blist {}
- set result [orExpr blist]
- if {$result} {
- # Calculate the union of result and b
- set reslist [opUnion $reslist $blist]
- }
- }
-
- return $result
-}
-
-
-proc orExpr { resname } {
- upvar $resname reslist
-
- set a [andExpr reslist]
- while ($a) {
- switch -- [lookahead] {
- or {
- advance
- set blist {}
- if {![andExpr blist]} {
- return 0
- }
-
- # Calculate a union b
- set reslist [opUnion $reslist $blist]
- }
- default {
- return $a
- }
- }
- }
-
- return $a
-}
-
-
-proc andExpr { resname } {
- upvar $resname reslist
-
- set a [unaryExpr reslist]
- while {$a} {
- switch -- [lookahead] {
- and {
- advance
-
- set blist {}
- set b [unaryExpr blist]
- if {!$b} {
- return 0
- }
-
- # Calculate a intersect b
- set reslist [opIntersection $reslist $blist]
- }
- default {
- return $a
- }
- }
- }
-
- return $a
-}
-
-
-proc unaryExpr { resname } {
- upvar $resname reslist
- set result 0
-
- switch -- [lookahead] {
- ! -
- not {
- advance
- set blist {}
- set result [unaryExpr blist]
- if {$result} {
- set all [get_all_ports]
- set reslist [opComplement $all $blist]
- }
- }
- default {
- set result [element reslist]
- }
- }
-
- return $result
-}
-
-
-proc element { resname } {
- upvar $resname reslist
- set el 0
-
- set url ""
- set name ""
- set version ""
- array unset requested_variants
- array unset options
-
- set token [lookahead]
- switch -regex -- $token {
- ^\\)$ -
- ^\; -
- ^_EOF_$ { # End of expression/cmd/file
- }
-
- ^\\($ { # Parenthesized Expression
- advance
- set el [portExpr reslist]
- if {!$el || ![match ")"]} {
- set el 0
- }
- }
-
- ^all(@.*)?$ -
- ^installed(@.*)?$ -
- ^uninstalled(@.*)?$ -
- ^active(@.*)?$ -
- ^inactive(@.*)?$ -
- ^actinact(@.*)?$ -
- ^leaves(@.*)?$ -
- ^outdated(@.*)?$ -
- ^obsolete(@.*)?$ -
- ^requested(@.*)?$ -
- ^unrequested(@.*)?$ -
- ^current(@.*)?$ {
- # A simple pseudo-port name
- advance
-
- # Break off the version component, if there is one
- regexp {^(\w+)(@.*)?} $token matchvar name remainder
-
- add_multiple_ports reslist [get_${name}_ports] $remainder
-
- set el 1
- }
-
- ^variants: -
- ^variant: -
- ^description: -
- ^portdir: -
- ^homepage: -
- ^epoch: -
- ^platforms: -
- ^platform: -
- ^name: -
- ^long_description: -
- ^maintainers: -
- ^maintainer: -
- ^categories: -
- ^category: -
- ^version: -
- ^depends_lib: -
- ^depends_build: -
- ^depends_run: -
- ^depends_extract: -
- ^depends_fetch: -
- ^replaced_by: -
- ^revision: -
- ^subport: -
- ^subports: -
- ^license: { # Handle special port selectors
- advance
-
- # Break up the token, because older Tcl switch doesn't support -matchvar
- regexp {^(\w+):(.*)} $token matchvar field pat
-
- # Remap friendly names to actual names
- set field [map_friendly_field_names $field]
-
- add_multiple_ports reslist [get_matching_ports $pat no regexp $field]
- set el 1
- }
-
- ^depends: { # A port selector shorthand for depends_{lib,build,run,fetch,extract}
- advance
-
- # Break up the token, because older Tcl switch doesn't support -matchvar
- regexp {^(\w+):(.*)} $token matchvar field pat
-
- add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_lib"]
- add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_build"]
- add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_run"]
- add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_extract"]
- add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_fetch"]
-
- set el 1
- }
-
- ^dependentof: -
- ^rdependentof: {
- advance
-
- # Break up the token, because older Tcl switch doesn't support -matchvar
- regexp {^(\w+):(.*)} $token matchvar selector portname
-
- set recursive [string equal $selector "rdependentof"]
- add_multiple_ports reslist [get_dependent_ports $portname $recursive]
-
- set el 1
- }
-
- ^depof: -
- ^rdepof: {
- advance
-
- # Break up the token, because older Tcl switch doesn't support -matchvar
- regexp {^(\w+):(.*)} $token matchvar selector portname
-
- set recursive [string equal $selector "rdepof"]
- add_multiple_ports reslist [get_dep_ports $portname $recursive]
-
- set el 1
- }
-
- ^subportof: {
- advance
-
- # Break up the token, because older Tcl switch doesn't support -matchvar
- regexp {^(\w+):(.*)} $token matchvar selector portname
-
- add_multiple_ports reslist [get_subports $portname]
-
- set el 1
- }
-
- [][?*] { # Handle portname glob patterns
- advance; add_multiple_ports reslist [get_matching_ports $token no glob]
- set el 1
- }
-
- ^\\w+:.+ { # Handle a url by trying to open it as a port and mapping the name
- advance
- set name [url_to_portname $token]
- if {$name ne ""} {
- parsePortSpec version requested_variants options
- add_to_portlist reslist [list url $token \
- name $name \
- version $version \
- requested_variants [array get requested_variants] \
- variants [array get requested_variants] \
- options [array get options]]
- set el 1
- } else {
- ui_error "Can't open URL '$token' as a port"
- set el 0
- }
- }
-
- default { # Treat anything else as a portspec (portname, version, variants, options
- # or some combination thereof).
- parseFullPortSpec url name version requested_variants options
- add_to_portlist reslist [list url $url \
- name $name \
- version $version \
- requested_variants [array get requested_variants] \
- variants [array get requested_variants] \
- options [array get options]]
- set el 1
- }
- }
-
- return $el
-}
-
-
-proc add_multiple_ports { resname ports {remainder ""} } {
- upvar $resname reslist
-
- set version ""
- array unset variants
- array unset options
- parsePortSpec version variants options $remainder
-
- array unset overrides
- if {$version ne ""} { set overrides(version) $version }
- if {[array size variants]} {
- # we always record the requested variants separately,
- # but requested ones always override existing ones
- set overrides(requested_variants) [array get variants]
- set overrides(variants) [array get variants]
- }
- if {[array size options]} { set overrides(options) [array get options] }
-
- add_ports_to_portlist reslist $ports [array get overrides]
-}
-
-
-proc unique_entries { entries } {
- # Form the list of all the unique elements in the list a,
- # considering only the port fullname, and taking the first
- # found element first
- set result {}
- array unset unique
- foreach item $entries {
- array set port $item
- if {[info exists unique($port(fullname))]} continue
- set unique($port(fullname)) 1
- lappend result $item
- }
- return $result
-}
-
-
-proc opUnion { a b } {
- # Return the unique elements in the combined two lists
- return [unique_entries [concat $a $b]]
-}
-
-
-proc opIntersection { a b } {
- set result {}
-
- # Rules we follow in performing the intersection of two port lists:
- #
- # a/, a/ ==> a/
- # a/, b/ ==>
- # a/, a/1.0 ==> a/1.0
- # a/1.0, a/ ==> a/1.0
- # a/1.0, a/2.0 ==>
- #
- # If there's an exact match, we take it.
- # If there's a match between simple and discriminated, we take the later.
-
- # First create a list of the fully discriminated names in b
- array unset bfull
- set i 0
- foreach bitem [unique_entries $b] {
- array set port $bitem
- set bfull($port(fullname)) $i
- incr i
- }
-
- # Walk through each item in a, matching against b
- foreach aitem [unique_entries $a] {
- array set port $aitem
-
- # Quote the fullname and portname to avoid special characters messing up the regexp
- set safefullname [regex_pat_sanitize $port(fullname)]
-
- set simpleform [expr { "$port(name)/" == $port(fullname) }]
- if {$simpleform} {
- set pat "^${safefullname}"
- } else {
- set safename [regex_pat_sanitize $port(name)]
- set pat "^${safefullname}$|^${safename}/$"
- }
-
- set matches [array names bfull -regexp $pat]
- foreach match $matches {
- if {$simpleform} {
- set i $bfull($match)
- lappend result [lindex $b $i]
- } else {
- lappend result $aitem
- }
- }
- }
-
- return $result
-}
-
-
-proc opComplement { a b } {
- set result {}
-
- # Return all elements of a not matching elements in b
-
- # First create a list of the fully discriminated names in b
- array unset bfull
- set i 0
- foreach bitem $b {
- array set port $bitem
- set bfull($port(fullname)) $i
- incr i
- }
-
- # Walk through each item in a, taking all those items that don't match b
- foreach aitem $a {
- array set port $aitem
-
- # Quote the fullname and portname to avoid special characters messing up the regexp
- set safefullname [regex_pat_sanitize $port(fullname)]
-
- set simpleform [expr { "$port(name)/" == $port(fullname) }]
- if {$simpleform} {
- set pat "^${safefullname}"
- } else {
- set safename [regex_pat_sanitize $port(name)]
- set pat "^${safefullname}$|^${safename}/$"
- }
-
- set matches [array names bfull -regexp $pat]
-
- # We copy this element to result only if it didn't match against b
- if {![llength $matches]} {
- lappend result $aitem
- }
- }
-
- return $result
-}
-
-
-proc parseFullPortSpec { urlname namename vername varname optname } {
- upvar $urlname porturl
- upvar $namename portname
- upvar $vername portversion
- upvar $varname portvariants
- upvar $optname portoptions
-
- set portname ""
- set portversion ""
- array unset portvariants
- array unset portoptions
-
- if { [moreargs] } {
- # Look first for a potential portname
- #
- # We need to allow a wide variety of tokens here, because of actions like "provides"
- # so we take a rather lenient view of what a "portname" is. We allow
- # anything that doesn't look like either a version, a variant, or an option
- set token [lookahead]
-
- set remainder ""
- if {|[[:alpha:]_]+[\w\.]*=)} $token match]} {
- advance
- regexp {^([^@]+)(@.*)?} $token match portname remainder
-
- # If the portname contains a /, then try to use it as a URL
- if {[string match "*/*" $portname]} {
- set url "file://$portname"
- set name [url_to_portname $url 1]
- if { $name ne "" } {
- # We mapped the url to valid port
- set porturl $url
- set portname $name
- # Continue to parse rest of portspec....
- } else {
- # We didn't map the url to a port; treat it
- # as a raw string for something like port contents
- # or cd
- set porturl ""
- # Since this isn't a port, we don't try to parse
- # any remaining portspec....
- return
- }
- }
- }
-
- # Now parse the rest of the spec
- parsePortSpec portversion portvariants portoptions $remainder
- }
-}
-
-# check if the install prefix is writable
-# should be called by actions that will modify it
-proc prefix_unwritable {} {
- global macports::portdbpath
- if {[file writable $portdbpath]} {
- return 0
- } else {
- ui_error "Insufficient privileges to write to MacPorts install prefix."
- return 1
- }
-}
-
-
-proc parsePortSpec { vername varname optname {remainder ""} } {
- upvar $vername portversion
- upvar $varname portvariants
- upvar $optname portoptions
-
- global global_options
-
- set portversion ""
- array unset portoptions
- array set portoptions [array get global_options]
- array unset portvariants
-
- # Parse port version/variants/options
- set opt $remainder
- set adv 0
- set consumed 0
- for {set firstTime 1} {$opt ne "" || [moreargs]} {set firstTime 0} {
-
- # Refresh opt as needed
- if {$opt eq ""} {
- if {$adv} advance
- set opt [lookahead]
- set adv 1
- set consumed 0
- }
-
- # Version must be first, if it's there at all
- if {$firstTime && [string match {@*} $opt]} {
- # Parse the version
-
- # Strip the @
- set opt [string range $opt 1 end]
-
- # Handle the version
- set sepPos [string first "/" $opt]
- if {$sepPos >= 0} {
- # Version terminated by "/" to disambiguate -variant from part of version
- set portversion [string range $opt 0 [expr {$sepPos - 1}]]
- set opt [string range $opt [expr {$sepPos + 1}] end]
- } else {
- # Version terminated by "+", or else is complete
- set sepPos [string first "+" $opt]
- if {$sepPos >= 0} {
- # Version terminated by "+"
- set portversion [string range $opt 0 [expr {$sepPos - 1}]]
- set opt [string range $opt $sepPos end]
- } else {
- # Unterminated version
- set portversion $opt
- set opt ""
- }
- }
- set consumed 1
- } else {
- # Parse all other options
-
- # Look first for a variable setting: VARNAME=VALUE
- if {[regexp {^([[:alpha:]_]+[\w\.]*)=(.*)} $opt match key val] == 1} {
- # It's a variable setting
- set portoptions($key) "\"$val\""
- set opt ""
- set consumed 1
- } elseif {[regexp {^([-+])([[:alpha:]_]+[\w\.]*)} $opt match sign variant] == 1} {
- # It's a variant
- set portvariants($variant) $sign
- set opt [string range $opt [expr {[string length $variant] + 1}] end]
- set consumed 1
- } else {
- # Not an option we recognize, so break from port option processing
- if { $consumed && $adv } advance
- break
- }
- }
- }
-}
-
-
-##########################################
-# Action Handlers
-##########################################
-
-proc action_get_usage { action } {
- global action_array cmd_opts_array
-
- if {[info exists action_array($action)]} {
- set cmds ""
- if {[info exists cmd_opts_array($action)]} {
- foreach opt $cmd_opts_array($action) {
- if {[llength $opt] == 1} {
- set name $opt
- set optc 0
- } else {
- set name [lindex $opt 0]
- set optc [lindex $opt 1]
- }
-
- append cmds " --$name"
-
- for {set i 1} {$i <= $optc} {incr i} {
- append cmds " <arg$i>"
- }
- }
- }
- set args ""
- set needed [action_needs_portlist $action]
- if {[ACTION_ARGS_STRINGS] == $needed} {
- set args " <arguments>"
- } elseif {[ACTION_ARGS_STRINGS] == $needed} {
- set args " <portlist>"
- }
-
- set ret "Usage: "
- set len [string length $action]
- append ret [wrap "$action$cmds$args" 0 [string repeat " " [expr {8 + $len}]] 0]
- append ret "\n"
-
- return $ret
- }
-
- return -1
-}
-
-proc action_usage { action portlist opts } {
- if {[llength $portlist] == 0} {
- print_usage
- return 0
- }
-
- foreach topic $portlist {
- set usage [action_get_usage $topic]
- if {$usage != -1} {
- puts -nonewline stderr $usage
- } else {
- ui_error "No usage for topic $topic"
- return 1
- }
- }
- return 0
-}
-
-
-proc action_help { action portlist opts } {
- set helpfile "$macports::prefix/var/macports/port-help.tcl"
-
- if {[llength $portlist] == 0} {
- print_help
- return 0
- }
-
- if {[file exists $helpfile]} {
- if {[catch {source $helpfile} err]} {
- puts stderr "Error reading helpfile $helpfile: $err"
- return 1
- }
- } else {
- puts stderr "Unable to open help file $helpfile"
- return 1
- }
-
- foreach topic $portlist {
- if {![info exists porthelp($topic)]} {
- puts stderr "No help for topic $topic"
- return 1
- }
-
- set usage [action_get_usage $topic]
- if {$usage != -1} {
- puts -nonewline stderr $usage
- } else {
- ui_error "No usage for topic $topic"
- return 1
- }
-
- puts stderr $porthelp($topic)
- }
-
- return 0
-}
-
-
-proc action_log { action portlist opts } {
- global global_options
- if {[require_portlist portlist]} {
- return 1
- }
- foreachport $portlist {
- # If we have a url, use that, since it's most specific
- # otherwise try to map the portname to a url
- if {$porturl eq ""} {
- # Verify the portname, getting portinfo to map to a porturl
- if {[catch {mportlookup $portname} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Port $portname not found" 1 status
- }
- array unset portinfo
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
- set portdir $portinfo(portdir)
- set portname $portinfo(name)
- } elseif {$porturl ne "file://."} {
- # Extract the portdir from porturl and use it to search PortIndex.
- # Only the last two elements of the path (porturl) make up the
- # portdir.
- set portdir [file split [macports::getportdir $porturl]]
- set lsize [llength $portdir]
- set portdir \
- [file join [lindex $portdir [expr {$lsize - 2}]] \
- [lindex $portdir [expr {$lsize - 1}]]]
- if {[catch {mportsearch $portdir no exact portdir} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Portdir $portdir not found" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Portdir $portdir not found" 1 status
- }
- array unset portinfo
- set matchindex [lsearch -exact -nocase $result $portname]
- if {$matchindex != -1} {
- array set portinfo [lindex $result [incr matchindex]]
- } else {
- ui_warn "Portdir $portdir doesn't seem to belong to portname $portname"
- array set portinfo [lindex $result 1]
- }
- set portname $portinfo(name)
- }
- set portpath [macports::getportdir $porturl]
- set logfile [file join [macports::getportlogpath $portpath $portname] "main.log"]
- if {[file exists $logfile]} {
- if {[catch {set fp [open $logfile r]} result]} {
- break_softcontinue "Could not open file $logfile: $result" 1 status
- }
- set data [read $fp]
- set data [split $data "\n"]
-
- if {[info exists global_options(ports_log_phase)]} {
- set phase $global_options(ports_log_phase);
- } else {
- set phase "\[a-z\]*"
- }
-
- if {[info exists global_options(ports_log_level)]} {
- set index [lsearch -exact ${macports::ui_priorities} $global_options(ports_log_level)]
- if {$index == -1} {
- set prefix ""
- } else {
- set prefix [join [lrange ${macports::ui_priorities} 0 $index] "|"]
- }
- } else {
- set prefix "\[a-z\]*"
- }
- foreach line $data {
- set exp "^:($prefix|any):($phase|any) (.*)$"
- if {[regexp $exp $line -> lpriority lphase lmsg] == 1} {
- puts "[macports::ui_prefix_default $lpriority]$lmsg"
- }
- }
-
- close $fp
- } else {
- break_softcontinue "Log file for port $portname not found" 1 status
- }
- }
- return 0
-}
-
-
-proc action_info { action portlist opts } {
- global global_variations
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
-
- set separator ""
- foreachport $portlist {
- set index_only 0
- if {[info exists options(ports_info_index)] && $options(ports_info_index)} {
- set index_only 1
- }
- puts -nonewline $separator
- array unset portinfo
- # If we have a url, use that, since it's most specific
- # otherwise try to map the portname to a url
- if {$porturl eq "" || $index_only} {
- # Verify the portname, getting portinfo to map to a porturl
- if {[catch {mportlookup $portname} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Port $portname not found" 1 status
- }
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
- set portdir $portinfo(portdir)
- }
-
- if {!$index_only} {
- # Add any global_variations to the variations
- # specified for the port (so we get e.g. dependencies right)
- array unset merged_variations
- array set merged_variations [array get variations]
- foreach { variation value } [array get global_variations] {
- if { ![info exists merged_variations($variation)] } {
- set merged_variations($variation) $value
- }
- }
- if {![info exists options(subport)]} {
- if {[info exists portinfo(name)]} {
- set options(subport) $portinfo(name)
- } else {
- set options(subport) $portname
- }
- }
-
- if {[catch {set mport [mportopen $porturl [array get options] [array get merged_variations]]} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Unable to open port: $result" 1 status
- }
- unset options(subport)
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
- if {[info exists portdir]} {
- set portinfo(portdir) $portdir
- }
- } elseif {![info exists portinfo]} {
- ui_warn "no PortIndex entry found for $portname"
- continue
- }
- array unset options ports_info_index
-
- # Understand which info items are actually lists
- # (this could be overloaded to provide a generic formatting code to
- # allow us to, say, split off the prefix on libs)
- array set list_map "
- categories 1
- depends_fetch 1
- depends_extract 1
- depends_build 1
- depends_lib 1
- depends_run 1
- maintainers 1
- platforms 1
- variants 1
- conflicts 1
- subports 1
- "
-
- # Label map for pretty printing
- array set pretty_label {
- heading ""
- variants Variants
- depends_fetch "Fetch Dependencies"
- depends_extract "Extract Dependencies"
- depends_build "Build Dependencies"
- depends_run "Runtime Dependencies"
- depends_lib "Library Dependencies"
- description "Brief Description"
- long_description "Description"
- fullname "Full Name: "
- homepage Homepage
- platforms Platforms
- maintainers Maintainers
- license License
- conflicts "Conflicts with"
- replaced_by "Replaced by"
- subports "Sub-ports"
- }
-
- # Wrap-length map for pretty printing
- array set pretty_wrap {
- heading 0
- replaced_by 22
- variants 22
- depends_fetch 22
- depends_extract 22
- depends_build 22
- depends_run 22
- depends_lib 22
- description 22
- long_description 22
- homepage 22
- platforms 22
- license 22
- conflicts 22
- maintainers 22
- subports 22
- }
-
- # Interpret a convenient field abbreviation
- if {[info exists options(ports_info_depends)] && $options(ports_info_depends) eq "yes"} {
- array unset options ports_info_depends
- set options(ports_info_depends_fetch) yes
- set options(ports_info_depends_extract) yes
- set options(ports_info_depends_build) yes
- set options(ports_info_depends_lib) yes
- set options(ports_info_depends_run) yes
- }
-
- # Set up our field separators
- set show_label 1
- set field_sep "\n"
- set subfield_sep ", "
- set pretty_print 0
-
- # For human-readable summary, which is the default with no options
- if {[llength [array get options ports_info_*]] == 0} {
- set pretty_print 1
- } elseif {[info exists options(ports_info_pretty)]} {
- set pretty_print 1
- array unset options ports_info_pretty
- }
-
- # Tune for sort(1)
- if {[info exists options(ports_info_line)]} {
- array unset options ports_info_line
- set noseparator 1
- set show_label 0
- set field_sep "\t"
- set subfield_sep ","
- }
-
- # Figure out whether to show field name
- set quiet [macports::ui_isset ports_quiet]
- if {$quiet} {
- set show_label 0
- }
- # In pretty-print mode we also suppress messages, even though we show
- # most of the labels:
- if {$pretty_print} {
- set quiet 1
- }
-
- # Spin through action options, emitting information for any found
- set fields {}
- set opts_todo [array names options ports_info_*]
- set fields_tried {}
- if {![llength $opts_todo]} {
- set opts_todo {ports_info_heading
- ports_info_replaced_by
- ports_info_subports
- ports_info_variants
- ports_info_skip_line
- ports_info_long_description ports_info_homepage
- ports_info_skip_line ports_info_depends_fetch
- ports_info_depends_extract ports_info_depends_build
- ports_info_depends_lib ports_info_depends_run
- ports_info_conflicts
- ports_info_platforms ports_info_license
- ports_info_maintainers
- }
- }
- foreach { option } $opts_todo {
- set opt [string range $option 11 end]
- # Artificial field name for formatting
- if {$pretty_print && $opt eq "skip_line"} {
- lappend fields ""
- continue
- }
- # Artificial field names to reproduce prettyprinted summary
- if {$opt eq "heading"} {
- set inf "$portinfo(name) @$portinfo(version)"
- set ropt "heading"
- if {[info exists portinfo(revision)] && $portinfo(revision) > 0} {
- append inf "_$portinfo(revision)"
- }
- if {[info exists portinfo(categories)]} {
- append inf " ([join $portinfo(categories) ", "])"
- }
- } elseif {$opt eq "fullname"} {
- set inf "$portinfo(name) @"
- append inf [composite_version $portinfo(version) $portinfo(active_variants)]
- set ropt "fullname"
- } else {
- # Map from friendly name
- set ropt [map_friendly_field_names $opt]
-
- # If there's no such info, move on
- if {![info exists portinfo($ropt)]} {
- set inf ""
- } else {
- set inf [join $portinfo($ropt)]
- }
- }
-
- # Calculate field label
- set label ""
- if {$pretty_print} {
- if {[info exists pretty_label($ropt)]} {
- set label $pretty_label($ropt)
- } else {
- set label $opt
- }
- } elseif {$show_label} {
- set label "$opt: "
- }
-
- # Format the data
- if { $ropt eq "maintainers" } {
- set inf [unobscure_maintainers $inf]
- }
- # ... special formatting for certain fields when prettyprinting
- if {$pretty_print} {
- if {$ropt eq "variants"} {
- # Use the new format for variants iff it exists in
- # PortInfo. This key currently does not exist outside of
- # trunk (1.8.0).
- array unset vinfo
- if {[info exists portinfo(vinfo)]} {
- array set vinfo $portinfo(vinfo)
- }
-
- set pi_vars $inf
- set inf {}
- foreach v [lsort $pi_vars] {
- set varmodifier ""
- if {[info exists variations($v)]} {
- # selected by command line, prefixed with +/-
- set varmodifier $variations($v)
- } elseif {[info exists global_variations($v)]} {
- # selected by variants.conf, prefixed with (+)/(-)
- set varmodifier "($global_variations($v))"
- # Retrieve additional information from the new key.
- } elseif {[info exists vinfo]} {
- array unset variant
- array set variant $vinfo($v)
- if {[info exists variant(is_default)]} {
- set varmodifier "\[$variant(is_default)]"
- }
- }
- lappend inf "$varmodifier$v"
- }
- } elseif {[string match "depend*" $ropt]
- && ![macports::ui_isset ports_verbose]} {
- set pi_deps $inf
- set inf {}
- foreach d $pi_deps {
- lappend inf [lindex [split $d :] end]
- }
- }
- }
- #End of special pretty-print formatting for certain fields
- if {[info exists list_map($ropt)]} {
- set field [join $inf $subfield_sep]
- } else {
- set field $inf
- }
-
- # Assemble the entry
- if {$pretty_print} {
- # The two special fields are considered headings and are
- # emitted immediately, rather than waiting. Also they are not
- # recorded on the list of fields tried
- if {$ropt eq "heading" || $ropt eq "fullname"} {
- puts "$label$field"
- continue
- }
- }
- lappend fields_tried $label
- if {$pretty_print} {
- if {$field eq ""} {
- continue
- }
- if {$label eq ""} {
- set wrap_len 0
- if {[info exists pretty_wrap($ropt)]} {
- set wrap_len $pretty_wrap($ropt)
- }
- lappend fields [wrap $field 0 [string repeat " " $wrap_len]]
- } else {
- set wrap_len [string length $label]
- if {[info exists pretty_wrap($ropt)]} {
- set wrap_len $pretty_wrap($ropt)
- }
- lappend fields [wraplabel $label $field 0 [string repeat " " $wrap_len]]
- }
-
- } else { # Not pretty print
- lappend fields "$label$field"
- }
- }
-
- # Now output all that information:
- if {[llength $fields]} {
- puts [join $fields $field_sep]
- } else {
- if {$pretty_print && [llength $fields_tried]} {
- puts -nonewline "$portinfo(name) has no "
- puts [join $fields_tried ", "]
- }
- }
- if {![info exists noseparator]} {
- set separator "--\n"
- }
- }
-
- return $status
-}
-
-
-proc action_location { action portlist opts } {
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
- foreachport $portlist {
- if { [catch {set ilist [registry_installed $portname [composite_version $portversion [array get variations]]]} result] } {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port location failed: $result" 1 status
- } else {
- # set portname again since the one we were passed may not have had the correct case
- set portname [lindex $ilist 0]
- set version [lindex $ilist 1]
- set revision [lindex $ilist 2]
- set variants [lindex $ilist 3]
- set epoch [lindex $ilist 5]
- }
-
- set ref [registry::open_entry $portname $version $revision $variants $epoch]
- set imagedir [registry::property_retrieve $ref location]
- ui_notice "Port $portname ${version}_${revision}${variants} is installed as an image in:"
- puts $imagedir
- }
-
- return $status
-}
-
-
-proc action_notes { action portlist opts } {
- if {[require_portlist portlist]} {
- return 1
- }
-
- set status 0
- foreachport $portlist {
- array unset portinfo
- if {$porturl eq ""} {
- # Look up the port.
- if {[catch {mportlookup $portname} result]} {
- ui_debug $::errorInfo
- break_softcontinue "The lookup of '$portname' failed: $result" \
- 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "The port '$portname' was not found" 1 status
- }
-
- # Retrieve the port's URL.
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
- }
-
- # Add any global_variations to the variations
- # specified for the port
- array unset merged_variations
- array set merged_variations [array get variations]
- foreach { variation value } [array get global_variations] {
- if { ![info exists merged_variations($variation)] } {
- set merged_variations($variation) $value
- }
- }
- if {![info exists options(subport)]} {
- if {[info exists portinfo(name)]} {
- set options(subport) $portinfo(name)
- } else {
- set options(subport) $portname
- }
- }
-
- # Open the Portfile associated with this port.
- if {[catch {set mport [mportopen $porturl [array get options] \
- [array get merged_variations]]} \
- result]} {
- ui_debug $::errorInfo
- break_softcontinue [concat "The URL '$porturl' could not be" \
- "opened: $result"] 1 status
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
-
- # Return the notes associated with this Portfile.
- if {[info exists portinfo(notes)]} {
- set portnotes $portinfo(notes)
- } else {
- set portnotes {}
- }
-
- # Retrieve the port's name once more to ensure it has the proper case.
- set portname $portinfo(name)
-
- # Display the notes.
- if {$portnotes ne {}} {
- ui_notice "$portname has the following notes:"
- foreach note $portnotes {
- puts [wrap $note 0 " " 1]
- }
- } else {
- puts "$portname has no notes."
- }
- }
- return $status
-}
-
-
-proc action_provides { action portlist opts } {
- # In this case, portname is going to be used for the filename... since
- # that is the first argument we expect... perhaps there is a better way
- # to do this?
- if { ![llength $portlist] } {
- ui_error "Please specify a filename to check which port provides that file."
- return 1
- }
- foreach filename $portlist {
- set file [file normalize $filename]
- if {[file exists $file] || ![catch {file type $file}]} {
- if {![file isdirectory $file] || [file type $file] eq "link"} {
- set port [registry::file_registered $file]
- if { $port != 0 } {
- puts "$file is provided by: $port"
- } else {
- puts "$file is not provided by a MacPorts port."
- }
- } else {
- puts "$file is a directory."
- }
- } else {
- puts "$file does not exist."
- }
- }
- registry::close_file_map
-
- return 0
-}
-
-
-proc action_activate { action portlist opts } {
- set status 0
- if {[require_portlist portlist] || [prefix_unwritable]} {
- return 1
- }
- foreachport $portlist {
- set composite_version [composite_version $portversion [array get variations]]
- if {![info exists options(ports_activate_no-exec)]
- && ![catch {set ilist [registry::installed $portname $composite_version]}]
- && [llength $ilist] == 1} {
-
- set i [lindex $ilist 0]
- set regref [registry::entry open $portname [lindex $i 1] [lindex $i 2] [lindex $i 3] [lindex $i 5]]
- if {[$regref installtype] eq "image" && [registry::run_target $regref activate [array get options]]} {
- continue
- }
- }
- if {![macports::global_option_isset ports_dryrun]} {
- if { [catch {portimage::activate_composite $portname $composite_version [array get options]} result] } {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port activate failed: $result" 1 status
- }
- } else {
- ui_msg "Skipping activate $portname (dry run)"
- }
- }
-
- return $status
-}
-
-
-proc action_deactivate { action portlist opts } {
- set status 0
- if {[require_portlist portlist] || [prefix_unwritable]} {
- return 1
- }
- set portlist [portlist_sortdependents $portlist]
- foreachport $portlist {
- set composite_version [composite_version $portversion [array get variations]]
- if {![info exists options(ports_deactivate_no-exec)]
- && ![catch {set ilist [registry::active $portname]}]} {
-
- set i [lindex $ilist 0]
- set iversion [lindex $i 1]
- set irevision [lindex $i 2]
- set ivariants [lindex $i 3]
- if {$composite_version eq "" || $composite_version == "${iversion}_${irevision}${ivariants}"} {
- set regref [registry::entry open $portname $iversion $irevision $ivariants [lindex $i 5]]
- if {[$regref installtype] eq "image" && [registry::run_target $regref deactivate [array get options]]} {
- continue
- }
- }
- }
- if {![macports::global_option_isset ports_dryrun]} {
- if { [catch {portimage::deactivate_composite $portname $composite_version [array get options]} result] } {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port deactivate failed: $result" 1 status
- }
- } else {
- ui_msg "Skipping deactivate $portname (dry run)"
- }
- }
-
- return $status
-}
-
-
-proc action_select { action portlist opts } {
- ui_debug "action_select \[$portlist] \[$opts]..."
-
- array set opts_array $opts
- set commands [array names opts_array ports_select_*]
- array unset opts_array
-
- # Error out if no group is specified or command is not --summary.
- if {[llength $portlist] < 1 && [string map {ports_select_ ""} [lindex $commands 0]] != "summary"} {
- ui_error "port select \[--list|--set|--show|--summary] \<group> \[<version>]"
- return 1
- }
-
- set group [lindex $portlist 0]
-
- # If no command (--set, --show, --list, --summary) is specified *but*
- # more than one argument is specified, default to the set command.
- if {[llength $commands] < 1 && [llength $portlist] > 1} {
- set command set
- ui_debug [concat "Although no command was specified, more than " \
- "one argument was specified. Defaulting to the " \
- "'set' command..."]
- # If no command (--set, --show, --list) is specified *and* less than two
- # argument are specified, default to the list command.
- } elseif {[llength $commands] < 1} {
- set command list
- ui_debug [concat "No command was specified. Defaulting to the " \
- "'list' command..."]
- # Only allow one command to be specified at a time.
- } elseif {[llength $commands] > 1} {
- ui_error [concat "Multiple commands were specified. Only one " \
- "command may be specified at a time."]
- return 1
- } else {
- set command [string map {ports_select_ ""} [lindex $commands 0]]
- ui_debug "The '$command' command was specified."
- }
-
- switch -- $command {
- list {
- if {[llength $portlist] > 1} {
- ui_warn [concat "The 'list' command does not expect any " \
- "arguments. Extra arguments will be ignored."]
- }
-
- if {[catch {mportselect show $group} selected_version]} {
- global errorInfo
- ui_debug $errorInfo
- ui_warn "Unable to get active selected version: $selected_version"
- }
-
- # On error mportselect returns with the code 'error'.
- if {[catch {mportselect $command $group} versions]} {
- ui_error "The 'list' command failed: $versions"
- return 1
- }
-
- ui_notice "Available versions for $group:"
- foreach v $versions {
- ui_notice -nonewline "\t"
- if {$selected_version == $v} {
- ui_msg "$v (active)"
- } else {
- ui_msg "$v"
- }
- }
- return 0
- }
- set {
- if {[llength $portlist] < 2} {
- ui_error [concat "The 'set' command expects two " \
- "arguments: <group>, <version>"]
- return 1
- } elseif {[llength $portlist] > 2} {
- ui_warn [concat "The 'set' command only expects two " \
- "arguments. Extra arguments will be " \
- "ignored."]
- }
- set version [lindex $portlist 1]
-
- ui_msg -nonewline "Selecting '$version' for '$group' "
- if {[catch {mportselect $command $group $version} result]} {
- ui_msg "failed: $result"
- return 1
- }
- ui_msg "succeeded. '$version' is now active."
- return 0
- }
- show {
- if {[llength $portlist] > 1} {
- ui_warn [concat "The 'show' command does not expect any " \
- "arguments. Extra arguments will be ignored."]
- }
-
- if {[catch {mportselect $command $group} selected_version]} {
- ui_error "The 'show' command failed: $selected_version"
- return 1
- }
- puts [concat "The currently selected version for '$group' is " \
- "'$selected_version'."]
- return 0
- }
- summary {
- if {[llength $portlist] > 0} {
- ui_warn [concat "The 'summary' command does not expect any " \
- "arguments. Extra arguments will be ignored."]
- }
-
- if {[catch {mportselect $command} portgroups]} {
- ui_error "The 'summary' command failed: $portgroups"
- return 1
- }
-
- set w1 4
- set w2 8
- set formatStr "%-*s %-*s %s"
-
- set groups [list]
- foreach pg $portgroups {
- array set groupdesc {}
- set groupdesc(name) [string trim $pg]
-
- if {[catch {mportselect list $pg} versions]} {
- ui_warn "The list of options for the select group $pg could not be obtained: $versions"
- continue
- }
- # remove "none", sort the list, append none at the end
- set noneidx [lsearch -exact $versions "none"]
- set versions [lsort [lreplace $versions $noneidx $noneidx]]
- lappend versions "none"
- set groupdesc(versions) $versions
-
- if {[catch {mportselect show $pg} selected_version]} {
- ui_warn "The currently selected option for the select group $pg could not be obtained: $selected_version"
- continue
- }
- set groupdesc(selected) $selected_version
-
- set w1 [expr {max($w1, [string length $pg])}]
- set w2 [expr {max($w2, [string length $selected_version])}]
-
- lappend groups [array get groupdesc]
- array unset groupdesc
- }
- puts [format $formatStr $w1 "Name" $w2 "Selected" "Options"]
- puts [format $formatStr $w1 "====" $w2 "========" "======="]
- foreach groupdesc $groups {
- array set groupd $groupdesc
- puts [format $formatStr $w1 $groupd(name) $w2 $groupd(selected) [join $groupd(versions) " "]]
- array unset groupd
- }
- return 0
- }
- default {
- ui_error "An unknown command '$command' was specified."
- return 1
- }
- }
-}
-
-
-proc action_selfupdate { action portlist opts } {
- global global_options
- if { [catch {macports::selfupdate [array get global_options] base_updated} result ] } {
- global errorInfo
- ui_debug "$errorInfo"
- ui_error "$result"
- if {![macports::ui_isset ports_verbose]} {
- ui_msg "Please run `port -v selfupdate' for details."
- } else {
- # Let's only print the ticket URL if the user has followed the
- # advice we printed earlier.
- print_tickets_url
- }
- fatal "port selfupdate failed: $result"
- }
-
- if {$base_updated} {
- # exit immediately if in batch/interactive mode
- return -999
- } else {
- return 0
- }
-}
-
-
-proc action_setrequested { action portlist opts } {
- set status 0
- if {[require_portlist portlist] || [prefix_unwritable]} {
- return 1
- }
- # set or unset?
- set val [string equal $action "setrequested"]
- foreachport $portlist {
- set composite_version [composite_version $portversion [array get variations]]
- if {![catch {set ilist [registry::installed $portname $composite_version]} result]} {
- ui_info "Setting requested flag for $portname to $val"
- foreach i $ilist {
- set regref [registry::open_entry $portname [lindex $i 1] [lindex $i 2] [lindex $i 3] [lindex $i 5]]
- registry::property_store $regref requested $val
- }
- } else {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "$result" 1 status
- }
- }
-
- return $status
-}
-
-
-proc action_upgrade { action portlist opts } {
- if {[require_portlist portlist "yes"] || ([prefix_unwritable] && ![macports::global_option_isset ports_dryrun])} {
- return 1
- }
-
- # shared depscache for all ports in the list
- array set depscache {}
- set status 0
- foreachport $portlist {
- if {![info exists depscache(port:$portname)]} {
- set status [macports::upgrade $portname "port:$portname" [array get requested_variations] [array get options] depscache]
- # status 2 means the port was not found in the index,
- # status 3 means the port is not installed
- if {$status != 0 && $status != 2 && $status != 3 && ![macports::ui_isset ports_processall]} {
- break
- }
- }
- }
-
- if {$status != 0 && $status != 2 && $status != 3} {
- print_tickets_url
- } elseif {$status == 0} {
- array set options $opts
- if {![info exists options(ports_upgrade_no-rev-upgrade)] && ${macports::revupgrade_autorun} && ![macports::global_option_isset ports_dryrun]} {
- set status [action_revupgrade $action $portlist $opts]
- }
- }
-
- return $status
-}
-
-proc action_reclaim { action portlist opts } {
- reclaim::main
- return 0
-}
-
-proc action_revupgrade { action portlist opts } {
- set status [macports::revupgrade $opts]
- if {$status != 0} {
- print_tickets_url
- }
- return $status
-}
-
-
-proc action_version { action portlist opts } {
- if {![macports::ui_isset ports_quiet]} {
- puts -nonewline "Version: "
- }
- puts [macports::version]
- return 0
-}
-
-
-proc action_platform { action portlist opts } {
- if {![macports::ui_isset ports_quiet]} {
- puts -nonewline "Platform: "
- }
- puts "${macports::os_platform} ${macports::os_major} ${macports::os_arch}"
- return 0
-}
-
-
-proc action_dependents { action portlist opts } {
- if {[require_portlist portlist]} {
- return 1
- }
- set ilist {}
-
- registry::open_dep_map
-
- set status 0
- foreachport $portlist {
- set composite_version [composite_version $portversion [array get variations]]
- if { [catch {set ilist [registry::installed $portname $composite_version]} result] } {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "$result" 1 status
- } else {
- # choose the active version if there is one
- set index 0
- foreach i $ilist {
- if {[lindex $i 4]} {
- set found 1
- break
- }
- incr index
- }
- if {![info exists found]} {
- set index 0
- }
- # set portname again since the one we were passed may not have had the correct case
- set portname [lindex $ilist $index 0]
- set iversion [lindex $ilist $index 1]
- set irevision [lindex $ilist $index 2]
- set ivariants [lindex $ilist $index 3]
- }
-
- set deplist [registry::list_dependents $portname $iversion $irevision $ivariants]
- if { [llength $deplist] > 0 } {
- if {$action eq "rdependents"} {
- set toplist $deplist
- while 1 {
- set newlist {}
- foreach dep $deplist {
- set depname [lindex $dep 2]
- if {![info exists seen($depname)]} {
- set seen($depname) 1
- set rdeplist [registry::list_dependents $depname]
- foreach rdep $rdeplist {
- lappend newlist $rdep
- }
- set dependentsof($depname) $rdeplist
- }
- }
- if {[llength $newlist] > 0} {
- set deplist $newlist
- } else {
- break
- }
- }
- set portstack [list $toplist]
- set pos_stack [list 0]
- array unset seen
- ui_notice "The following ports are dependent on ${portname}:"
- while 1 {
- set cur_portlist [lindex $portstack end]
- set cur_pos [lindex $pos_stack end]
- if {$cur_pos >= [llength $cur_portlist]} {
- set portstack [lreplace $portstack end end]
- set pos_stack [lreplace $pos_stack end end]
- if {[llength $portstack] <= 0} {
- break
- } else {
- continue
- }
- }
- set cur_port [lindex $cur_portlist $cur_pos]
- set cur_portname [lindex $cur_port 2]
- set spaces [string repeat " " [expr {[llength $pos_stack] * 2}]]
- if {![info exists seen($cur_portname)] || ([info exists options(ports_rdependents_full)] && [string is true -strict $options(ports_rdependents_full)])} {
- puts "${spaces}${cur_portname}"
- set seen($cur_portname) 1
- incr cur_pos
- set pos_stack [lreplace $pos_stack end end $cur_pos]
- if {[info exists dependentsof($cur_portname)]} {
- lappend portstack $dependentsof($cur_portname)
- lappend pos_stack 0
- }
- continue
- }
- incr cur_pos
- set pos_stack [lreplace $pos_stack end end $cur_pos]
- }
- } else {
- foreach dep $deplist {
- set depport [lindex $dep 2]
- if {[macports::ui_isset ports_quiet]} {
- ui_msg "$depport"
- } elseif {![macports::ui_isset ports_verbose]} {
- ui_msg "$depport depends on $portname"
- } else {
- ui_msg "$depport depends on $portname (by [lindex $dep 1]:)"
- }
- }
- }
- } else {
- ui_notice "$portname has no dependents."
- }
- }
- return $status
-}
-
-
-proc action_deps { action portlist opts } {
- global global_variations
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
- set separator ""
-
- foreachport $portlist {
- if {[info exists options(ports_${action}_no-build)] && [string is true -strict $options(ports_${action}_no-build)]} {
- set deptypes {depends_lib depends_run}
- } else {
- set deptypes {depends_fetch depends_extract depends_build depends_lib depends_run}
- }
-
- array unset portinfo
- # If we have a url, use that, since it's most specific
- # otherwise try to map the portname to a url
- if {$porturl eq ""} {
- # Verify the portname, getting portinfo to map to a porturl
- if {[catch {mportlookup $portname} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Port $portname not found" 1 status
- }
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
- } elseif {$porturl ne "file://."} {
- # Extract the portdir from porturl and use it to search PortIndex.
- # Only the last two elements of the path (porturl) make up the
- # portdir.
- set portdir [file split [macports::getportdir $porturl]]
- set lsize [llength $portdir]
- set portdir \
- [file join [lindex $portdir [expr {$lsize - 2}]] \
- [lindex $portdir [expr {$lsize - 1}]]]
- if {[catch {mportsearch $portdir no exact portdir} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Portdir $portdir not found" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Portdir $portdir not found" 1 status
- }
- set matchindex [lsearch -exact -nocase $result $portname]
- if {$matchindex != -1} {
- array set portinfo [lindex $result [incr matchindex]]
- } else {
- ui_warn "Portdir $portdir doesn't seem to belong to portname $portname"
- array set portinfo [lindex $result 1]
- }
- }
-
- if {!([info exists options(ports_${action}_index)] && $options(ports_${action}_index) eq "yes")} {
- # Add any global_variations to the variations
- # specified for the port, so we get dependencies right
- array unset merged_variations
- array set merged_variations [array get variations]
- foreach { variation value } [array get global_variations] {
- if { ![info exists merged_variations($variation)] } {
- set merged_variations($variation) $value
- }
- }
- if {![info exists options(subport)]} {
- if {[info exists portinfo(name)]} {
- set options(subport) $portinfo(name)
- } else {
- set options(subport) $portname
- }
- }
- if {[catch {set mport [mportopen $porturl [array get options] [array get merged_variations]]} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Unable to open port: $result" 1 status
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
- } elseif {![info exists portinfo]} {
- ui_warn "port ${action} --index does not work with the 'current' pseudo-port"
- continue
- }
- set portname $portinfo(name)
-
- set deplist {}
- set deps_output {}
- set ndeps 0
- array set labeldict {depends_fetch Fetch depends_extract Extract depends_build Build depends_lib Library depends_run Runtime}
- # get list of direct deps
- foreach type $deptypes {
- if {[info exists portinfo($type)]} {
- if {$action eq "rdeps" || [macports::ui_isset ports_verbose]} {
- foreach dep $portinfo($type) {
- lappend deplist $dep
- }
- } else {
- foreach dep $portinfo($type) {
- lappend deplist [lindex [split $dep :] end]
- }
- }
- if {$action eq "deps"} {
- set label "$labeldict($type) Dependencies"
- lappend deps_output [wraplabel $label [join $deplist ", "] 0 [string repeat " " 22]]
- incr ndeps [llength $deplist]
- set deplist {}
- }
- }
- }
-
- set version $portinfo(version)
- set revision $portinfo(revision)
- if {[info exists portinfo(canonical_active_variants)]} {
- set variants $portinfo(canonical_active_variants)
- } else {
- set variants {}
- }
-
- puts -nonewline $separator
- if {$action eq "deps"} {
- if {$ndeps == 0} {
- ui_notice "$portname @${version}_${revision}${variants} has no dependencies."
- } else {
- ui_notice "Full Name: $portname @${version}_${revision}${variants}"
- puts [join $deps_output "\n"]
- }
- set separator "--\n"
- continue
- }
-
- set toplist $deplist
- # gather all the deps
- while 1 {
- set newlist {}
- foreach dep $deplist {
- set depname [lindex [split $dep :] end]
- if {![info exists seen($depname)]} {
- set seen($depname) 1
-
- # look up the dep
- if {[catch {mportlookup $depname} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "lookup of portname $depname failed: $result" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Port $depname not found" 1 status
- }
- array unset portinfo
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
- set options(subport) $portinfo(name)
-
- # open the portfile if requested
- if {!([info exists options(ports_${action}_index)] && $options(ports_${action}_index) eq "yes")} {
- if {[catch {set mport [mportopen $porturl [array get options] [array get merged_variations]]} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Unable to open port: $result" 1 status
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
- }
-
- # get list of the dep's deps
- set rdeplist {}
- foreach type $deptypes {
- if {[info exists portinfo($type)]} {
- foreach rdep $portinfo($type) {
- lappend rdeplist $rdep
- lappend newlist $rdep
- }
- }
- }
- set depsof($depname) $rdeplist
- }
- }
- if {[llength $newlist] > 0} {
- set deplist $newlist
- } else {
- break
- }
- }
- set portstack [list $toplist]
- set pos_stack [list 0]
- array unset seen
- if {[llength $toplist] > 0} {
- ui_notice "The following ports are dependencies of $portname @${version}_${revision}${variants}:"
- } else {
- ui_notice "$portname @${version}_${revision}${variants} has no dependencies."
- }
- while 1 {
- set cur_portlist [lindex $portstack end]
- set cur_pos [lindex $pos_stack end]
- if {$cur_pos >= [llength $cur_portlist]} {
- set portstack [lreplace $portstack end end]
- set pos_stack [lreplace $pos_stack end end]
- if {[llength $portstack] <= 0} {
- break
- } else {
- continue
- }
- }
- set cur_port [lindex $cur_portlist $cur_pos]
- set cur_portname [lindex [split $cur_port :] end]
- set spaces [string repeat " " [expr {[llength $pos_stack] * 2}]]
- if {![info exists seen($cur_portname)] || ([info exists options(ports_${action}_full)] && [string is true -strict $options(ports_${action}_full)])} {
- if {[macports::ui_isset ports_verbose]} {
- puts "${spaces}${cur_port}"
- } else {
- puts "${spaces}${cur_portname}"
- }
- set seen($cur_portname) 1
- incr cur_pos
- set pos_stack [lreplace $pos_stack end end $cur_pos]
- if {[info exists depsof($cur_portname)]} {
- lappend portstack $depsof($cur_portname)
- lappend pos_stack 0
- }
- continue
- }
- incr cur_pos
- set pos_stack [lreplace $pos_stack end end $cur_pos]
- }
- set separator "--\n"
- }
- return $status
-}
-
-
-proc action_uninstall { action portlist opts } {
- set status 0
- if {[macports::global_option_isset port_uninstall_old]} {
- # if -u then uninstall all inactive ports
- # (union these to any other ports user has in the port list)
- set portlist [opUnion $portlist [get_inactive_ports]]
- } else {
- # Otherwise the user hopefully supplied a portlist, or we'll default to the existing directory
- if {[require_portlist portlist]} {
- return 1
- }
- }
- if {[prefix_unwritable]} {
- return 1
- }
-
- set portlist [portlist_sortdependents $portlist]
-
- foreachport $portlist {
- if {![registry::entry_exists_for_name $portname]} {
- # if the code path arrives here the port either isn't installed, or
- # it doesn't exist at all. We can't be sure, but we can check the
- # portindex whether a port by that name exists (in which case not
- # uninstalling it is probably no problem). If there is no port by
- # that name, alert the user in case of typos.
- ui_info "$portname is not installed"
- if {[catch {set res [mportlookup $portname]} result] || [llength $res] == 0} {
- ui_warn "no such port: $portname, skipping uninstall"
- }
- continue
- }
- set composite_version [composite_version $portversion [array get variations]]
- if {![info exists options(ports_uninstall_no-exec)]
- && ![catch {set ilist [registry::installed $portname $composite_version]}]
- && [llength $ilist] == 1} {
-
- set i [lindex $ilist 0]
- set iactive [lindex $i 4]
- set regref [registry::entry open $portname [lindex $i 1] [lindex $i 2] [lindex $i 3] [lindex $i 5]]
- if {[registry::run_target $regref uninstall [array get options]]} {
- continue
- }
- }
-
- if { [catch {registry_uninstall::uninstall_composite $portname $composite_version [array get options]} result] } {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port uninstall failed: $result" 1 status
- }
- }
-
- return $status
-}
-
-
-proc action_installed { action portlist opts } {
- global private_options
- set status 0
- set restrictedList 0
- set ilist {}
-
- if { [llength $portlist] || (![info exists private_options(ports_no_args)] || $private_options(ports_no_args) eq "no")} {
- set restrictedList 1
- foreachport $portlist {
- set composite_version [composite_version $portversion [array get variations]]
- if { [catch {set ilist [concat $ilist [registry::installed $portname $composite_version]]} result] } {
- if {![string match "* not registered as installed." $result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port installed failed: $result" 1 status
- }
- }
- }
- } else {
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- ui_error "port installed failed: $result"
- set status 1
- }
- }
- }
- if { [llength $ilist] > 0 } {
- ui_notice "The following ports are currently installed:"
- foreach i [portlist_sortint $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]
- set extra ""
- set nvariants ""
- if {[macports::ui_isset ports_verbose]} {
- set regref [registry::open_entry $iname $iversion $irevision $ivariants [lindex $i 5]]
- set nvariants [registry::property_retrieve $regref negated_variants]
- if {$nvariants == 0} {
- set nvariants ""
- }
- set os_platform [registry::property_retrieve $regref os_platform]
- set os_major [registry::property_retrieve $regref os_major]
- set archs [registry::property_retrieve $regref archs]
- if {$os_platform != 0 && $os_platform ne "" && $os_major != 0 && $os_major ne ""} {
- append extra " platform='$os_platform $os_major'"
- }
- if {$archs != 0 && $archs ne ""} {
- append extra " archs='$archs'"
- }
- }
- if { $iactive == 0 } {
- puts " $iname @${iversion}_${irevision}${ivariants}${nvariants}${extra}"
- } elseif { $iactive == 1 } {
- puts " $iname @${iversion}_${irevision}${ivariants}${nvariants} (active)${extra}"
- }
- }
- } elseif { $restrictedList } {
- ui_notice "None of the specified ports are installed."
- } else {
- ui_notice "No ports are installed."
- }
-
- return $status
-}
-
-
-proc action_outdated { action portlist opts } {
- global private_options
- set status 0
-
- # If port names were supplied, limit ourselves to those ports, else check all installed ports
- set ilist {}
- set restrictedList 0
- if { [llength $portlist] || (![info exists private_options(ports_no_args)] || $private_options(ports_no_args) eq "no")} {
- set restrictedList 1
- foreach portspec $portlist {
- array set port $portspec
- set portname $port(name)
- set composite_version [composite_version $port(version) $port(variants)]
- if { [catch {set ilist [concat $ilist [registry::installed $portname $composite_version]]} result] } {
- if {![string match "* not registered as installed." $result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port outdated failed: $result" 1 status
- }
- }
- }
- } else {
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- ui_error "port installed failed: $result"
- set status 1
- }
- }
- }
-
- set num_outdated 0
- if { [llength $ilist] > 0 } {
- foreach i [portlist_sortint $ilist] {
-
- # Get information about the installed port
- set portname [lindex $i 0]
- set installed_version [lindex $i 1]
- set installed_revision [lindex $i 2]
- set installed_compound "${installed_version}_${installed_revision}"
-
- set is_active [lindex $i 4]
- if {$is_active == 0} {
- continue
- }
- set installed_epoch [lindex $i 5]
-
- # Get info about the port from the index
- if {[catch {set res [mportlookup $portname]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "search for portname $portname failed: $result" 1 status
- }
- if {[llength $res] < 2} {
- if {[macports::ui_isset ports_debug]} {
- puts "$portname ($installed_compound is installed; the port was not found in the port index)"
- }
- continue
- }
- array unset portinfo
- array set portinfo [lindex $res 1]
-
- # Get information about latest available version and revision
- if {![info exists portinfo(version)]} {
- ui_warn "$portname has no version field"
- continue
- }
- set latest_version $portinfo(version)
- set latest_revision 0
- if {[info exists portinfo(revision)] && $portinfo(revision) > 0} {
- set latest_revision $portinfo(revision)
- }
- set latest_compound "${latest_version}_${latest_revision}"
- set latest_epoch 0
- if {[info exists portinfo(epoch)]} {
- set latest_epoch $portinfo(epoch)
- }
-
- # Compare versions, first checking epoch, then version, then revision
- set epoch_comp_result [expr {$installed_epoch - $latest_epoch}]
- set comp_result [vercmp $installed_version $latest_version]
- if { $comp_result == 0 } {
- set comp_result [expr {$installed_revision - $latest_revision}]
- }
- set reason ""
- if {$epoch_comp_result != 0 && $installed_version != $latest_version} {
- if {($comp_result >= 0 && $epoch_comp_result < 0) || ($comp_result <= 0 && $epoch_comp_result > 0)} {
- set reason { (epoch $installed_epoch $relation $latest_epoch)}
- }
- set comp_result $epoch_comp_result
- } elseif {$comp_result == 0} {
- set regref [registry::open_entry $portname $installed_version $installed_revision [lindex $i 3] $installed_epoch]
- set os_platform_installed [registry::property_retrieve $regref os_platform]
- set os_major_installed [registry::property_retrieve $regref os_major]
- if {$os_platform_installed ne "" && $os_platform_installed != 0
- && $os_major_installed ne "" && $os_major_installed != 0
- && ($os_platform_installed != ${macports::os_platform} || $os_major_installed != ${macports::os_major})} {
- set comp_result -1
- set reason { (platform $os_platform_installed $os_major_installed != ${macports::os_platform} ${macports::os_major})}
- }
- }
-
- # Report outdated (or, for verbose, predated) versions
- if { $comp_result != 0 } {
-
- # Form a relation between the versions
- set flag ""
- if { $comp_result > 0 } {
- set relation ">"
- set flag "!"
- } else {
- set relation "<"
- }
-
- # Emit information
- if {$comp_result < 0 || [macports::ui_isset ports_verbose]} {
-
- if {$num_outdated == 0} {
- ui_notice "The following installed ports are outdated:"
- }
- incr num_outdated
-
- puts [format "%-30s %-24s %1s" $portname "$installed_compound $relation $latest_compound [subst $reason]" $flag]
- }
-
- }
- }
-
- if {$num_outdated == 0} {
- ui_notice "No installed ports are outdated."
- }
- } elseif { $restrictedList } {
- ui_notice "None of the specified ports are outdated."
- } else {
- ui_notice "No ports are installed."
- }
-
- return $status
-}
-
-
-proc action_contents { action portlist opts } {
- global global_options
- if {[require_portlist portlist]} {
- return 1
- }
- if {[info exists global_options(ports_contents_size)]} {
- set units {}
- if {[info exists global_options(ports_contents_units)]} {
- set units [complete_size_units $global_options(ports_contents_units)]
- }
- set outstring {[format "%12s $file" [filesize $file $units]]}
- } else {
- set outstring { $file}
- }
-
- foreachport $portlist {
- if { ![catch {set ilist [registry::installed $portname]} result] } {
- # set portname again since the one we were passed may not have had the correct case
- set portname [lindex $ilist 0 0]
- }
- set files [registry::port_registered $portname]
- if { $files != 0 } {
- if { [llength $files] > 0 } {
- ui_notice "Port $portname contains:"
- foreach file $files {
- puts [subst $outstring]
- }
- } else {
- ui_notice "Port $portname does not contain any files or is not active."
- }
- } else {
- ui_notice "Port $portname is not installed."
- }
- }
- registry::close_file_map
-
- return 0
-}
-
-# expand abbreviations of size units
-proc complete_size_units {units} {
- if {$units eq "K" || $units eq "Ki"} {
- return "KiB"
- } elseif {$units eq "k"} {
- return "kB"
- } elseif {$units eq "Mi"} {
- return "MiB"
- } elseif {$units eq "M"} {
- return "MB"
- } elseif {$units eq "Gi"} {
- return "GiB"
- } elseif {$units eq "G"} {
- return "GB"
- } else {
- return $units
- }
-}
-
-# Show space used by the given ports' files
-proc action_space {action portlist opts} {
- global global_options
- require_portlist portlist
-
- set units {}
- if {[info exists global_options(ports_space_units)]} {
- set units [complete_size_units $global_options(ports_space_units)]
- }
- set spaceall 0.0
- foreachport $portlist {
- set space 0.0
- set files [registry::port_registered $portname]
- if { $files != 0 } {
- if { [llength $files] > 0 } {
- foreach file $files {
- catch {
- set space [expr {$space + [file size $file]}]
- }
- }
- if {![info exists options(ports_space_total)] || $options(ports_space_total) ne "yes"} {
- set msg "[bytesize $space $units] $portname"
- if { $portversion != {} } {
- append msg " @$portversion"
- }
- puts $msg
- }
- set spaceall [expr {$space + $spaceall}]
- } else {
- puts stderr "Port $portname does not contain any file or is not active."
- }
- } else {
- puts stderr "Port $portname is not installed."
- }
- }
- if {[llength $portlist] > 1 || ([info exists options(ports_space_total)] && $options(ports_space_total) eq "yes")} {
- puts "[bytesize $spaceall $units] total"
- }
- return 0
-}
-
-proc action_variants { action portlist opts } {
- global global_variations
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
- foreachport $portlist {
- array unset portinfo
- if {$porturl eq ""} {
- # look up port
- if {[catch {mportlookup $portname} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Port $portname not found" 1 status
- }
-
- array set portinfo [lindex $result 1]
-
- set porturl $portinfo(porturl)
- set portdir $portinfo(portdir)
- }
-
- if {!([info exists options(ports_variants_index)] && $options(ports_variants_index) eq "yes")} {
- if {![info exists options(subport)]} {
- if {[info exists portinfo(name)]} {
- set options(subport) $portinfo(name)
- } else {
- set options(subport) $portname
- }
- }
- if {[catch {set mport [mportopen $porturl [array get options] [array get variations]]} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Unable to open port: $result" 1 status
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
- if {[info exists portdir]} {
- set portinfo(portdir) $portdir
- }
- } elseif {![info exists portinfo]} {
- ui_warn "port variants --index does not work with 'current' pseudo-port"
- continue
- }
-
- # set portname again since the one we were passed may not have had the correct case
- set portname $portinfo(name)
-
- # if this fails the port doesn't have any variants
- if {![info exists portinfo(variants)]} {
- ui_notice "$portname has no variants"
- } else {
- array unset vinfo
- # Use the new format if it exists.
- if {[info exists portinfo(vinfo)]} {
- array set vinfo $portinfo(vinfo)
- # Otherwise fall back to the old format.
- } elseif {[info exists portinfo(variant_desc)]} {
- array set vdescriptions $portinfo(variant_desc)
- }
-
- # print out all the variants
- ui_notice "$portname has the variants:"
- foreach v [lsort $portinfo(variants)] {
- unset -nocomplain vconflicts vdescription vrequires
- set varmodifier " "
- # Retrieve variants' information from the new format.
- if {[info exists vinfo]} {
- array unset variant
- array set variant $vinfo($v)
-
- # Retrieve conflicts, description, is_default, and
- # vrequires.
- if {[info exists variant(conflicts)]} {
- set vconflicts $variant(conflicts)
- }
- if {[info exists variant(description)]} {
- set vdescription $variant(description)
- }
-
- # XXX Keep these varmodifiers in sync with action_info, or create a wrapper for it
- if {[info exists variations($v)]} {
- set varmodifier " $variations($v)"
- } elseif {[info exists global_variations($v)]} {
- # selected by variants.conf, prefixed with (+)/(-)
- set varmodifier "($global_variations($v))"
- } elseif {[info exists variant(is_default)]} {
- set varmodifier "\[$variant(is_default)\]"
- }
- if {[info exists variant(requires)]} {
- set vrequires $variant(requires)
- }
- # Retrieve variants' information from the old format,
- # which only consists of the description.
- } elseif {[info exists vdescriptions($v)]} {
- set vdescription $vdescriptions($v)
- }
-
- if {[info exists vdescription]} {
- puts [wraplabel "$varmodifier$v" [string trim $vdescription] 0 [string repeat " " [expr 5 + [string length $v]]]]
- } else {
- puts "$varmodifier$v"
- }
- if {[info exists vconflicts]} {
- puts " * conflicts with [string trim $vconflicts]"
- }
- if {[info exists vrequires]} {
- puts " * requires [string trim $vrequires]"
- }
- }
- }
- }
-
- return $status
-}
-
-
-proc action_search { action portlist opts } {
- global private_options global_options
- set status 0
- if {![llength $portlist] && [info exists private_options(ports_no_args)] && $private_options(ports_no_args) eq "yes"} {
- ui_error "You must specify a search pattern"
- return 1
- }
-
- # Copy global options as we are going to modify the array
- array set options [array get global_options]
-
- if {[info exists options(ports_search_depends)] && $options(ports_search_depends) eq "yes"} {
- array unset options ports_search_depends
- set options(ports_search_depends_fetch) yes
- set options(ports_search_depends_extract) yes
- set options(ports_search_depends_build) yes
- set options(ports_search_depends_lib) yes
- set options(ports_search_depends_run) yes
- }
-
- # Array to hold given filters
- array set filters {}
- # Default matchstyle
- set filter_matchstyle "none"
- set filter_case no
- foreach { option } [array names options ports_search_*] {
- set opt [string range $option 13 end]
-
- if { $options($option) ne "yes" } {
- continue
- }
- switch -- $opt {
- exact -
- glob {
- set filter_matchstyle $opt
- continue
- }
- regex {
- set filter_matchstyle regexp
- continue
- }
- case-sensitive {
- set filter_case yes
- continue
- }
- line {
- continue
- }
- }
-
- set filters($opt) "yes"
- }
- # Set default search filter if none was given
- if { [array size filters] == 0 } {
- set filters(name) "yes"
- set filters(description) "yes"
- }
-
- set separator ""
- foreach portname $portlist {
- puts -nonewline $separator
-
- set searchstring $portname
- set matchstyle $filter_matchstyle
- if {$matchstyle eq "none"} {
- # Guess if the given string was a glob expression, if not do a substring search
- if {[string first "*" $portname] == -1 && [string first "?" $portname] == -1} {
- set searchstring "*$portname*"
- }
- set matchstyle glob
- }
-
- set res {}
- set portfound 0
- foreach { opt } [array get filters] {
- # Map from friendly name
- set opt [map_friendly_field_names $opt]
-
- if {[catch {eval set matches \[mportsearch \$searchstring $filter_case \$matchstyle $opt\]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "search for name $portname failed: $result" 1 status
- }
-
- set tmp {}
- foreach {name info} $matches {
- add_to_portlist tmp [concat [list name $name] $info]
- }
- set res [opUnion $res $tmp]
- }
- set res [portlist_sort $res]
-
- set joiner ""
- foreach info $res {
- array unset portinfo
- array set portinfo $info
-
- # XXX is this the right place to verify an entry?
- if {![info exists portinfo(name)]} {
- puts stderr "Invalid port entry, missing portname"
- continue
- }
- if {![info exists portinfo(description)]} {
- puts stderr "Invalid port entry for $portinfo(name), missing description"
- continue
- }
- if {![info exists portinfo(version)]} {
- puts stderr "Invalid port entry for $portinfo(name), missing version"
- continue
- }
-
- if {[macports::ui_isset ports_quiet]} {
- puts $portinfo(name)
- } else {
- if {[info exists options(ports_search_line)]
- && $options(ports_search_line) eq "yes"} {
- # check for ports without category, e.g. replaced_by stubs
- if {[info exists portinfo(categories)]} {
- puts "$portinfo(name)\t$portinfo(version)\t$portinfo(categories)\t$portinfo(description)"
- } else {
- # keep two consecutive tabs in order to provide consistent columns' content
- puts "$portinfo(name)\t$portinfo(version)\t\t$portinfo(description)"
- }
- } else {
- puts -nonewline $joiner
-
- puts -nonewline "$portinfo(name) @$portinfo(version)"
- if {[info exists portinfo(revision)] && $portinfo(revision) > 0} {
- puts -nonewline "_$portinfo(revision)"
- }
- if {[info exists portinfo(categories)]} {
- puts -nonewline " ([join $portinfo(categories) ", "])"
- }
- puts ""
- puts [wrap [join $portinfo(description)] 0 [string repeat " " 4]]
- }
- }
-
- set joiner "\n"
- set portfound 1
- }
- if { !$portfound } {
- ui_notice "No match for $portname found"
- } elseif {[llength $res] > 1} {
- if {(![info exists global_options(ports_search_line)]
- || $global_options(ports_search_line) ne "yes")} {
- ui_notice "\nFound [llength $res] ports."
- }
- }
-
- set separator "--\n"
- }
-
- array unset options
- array unset filters
-
- return $status
-}
-
-
-proc action_list { action portlist opts } {
- global private_options
- set status 0
-
- # Default to list all ports if no portnames are supplied
- if { ![llength $portlist] && [info exists private_options(ports_no_args)] && $private_options(ports_no_args) eq "yes"} {
- add_to_portlist portlist [list name "-all-"]
- }
-
- foreachport $portlist {
- if {$portname eq "-all-"} {
- if {[catch {set res [mportlistall]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "listing all ports failed: $result" 1 status
- }
- } else {
- set search_string [regex_pat_sanitize $portname]
- if {[catch {set res [mportsearch ^$search_string\$ no]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "search for portname $search_string failed: $result" 1 status
- }
- }
-
- foreach {name array} $res {
- array unset portinfo
- array set portinfo $array
- set outdir ""
- if {[info exists portinfo(portdir)]} {
- set outdir $portinfo(portdir)
- }
- puts [format "%-30s @%-14s %s" $portinfo(name) $portinfo(version) $outdir]
- }
- }
-
- return $status
-}
-
-
-proc action_echo { action portlist opts } {
- global global_options
-
- # Simply echo back the port specs given to this command
- foreachport $portlist {
- if {![macports::ui_isset ports_quiet]} {
- set opts {}
- foreach { key value } [array get options] {
- if {![info exists global_options($key)]} {
- lappend opts "$key=$value"
- }
- }
-
- set composite_version [composite_version $portversion [array get variations] 1]
- if { $composite_version ne "" } {
- set ver_field "@$composite_version"
- } else {
- set ver_field ""
- }
- puts [format "%-30s %s %s" $portname $ver_field [join $opts " "]]
- } else {
- puts "$portname"
- }
- }
-
- return 0
-}
-
-
-proc action_portcmds { action portlist opts } {
- # Operations on the port's directory and Portfile
- global env boot_env current_portdir
-
- array set local_options $opts
-
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
- foreachport $portlist {
- array unset portinfo
- # If we have a url, use that, since it's most specific, otherwise try to map the portname to a url
- if {$porturl eq ""} {
-
- # Verify the portname, getting portinfo to map to a porturl
- if {[catch {set res [mportlookup $portname]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $res] < 2} {
- break_softcontinue "Port $portname not found" 1 status
- }
- array set portinfo [lindex $res 1]
- set porturl $portinfo(porturl)
- set portname $portinfo(name)
- }
-
-
- # Calculate portdir, porturl, and portfile from initial porturl
- set portdir [file normalize [macports::getportdir $porturl]]
- set porturl "file://${portdir}"; # Rebuild url so it's fully qualified
- set portfile "${portdir}/Portfile"
-
- # Now execute the specific action
- if {[file readable $portfile]} {
- switch -- $action {
- cat {
- # Copy the portfile to standard output
- set f [open $portfile RDONLY]
- while { ![eof $f] } {
- puts -nonewline [read $f 4096]
- }
- close $f
- }
-
- edit {
- # Edit the port's portfile with the user's editor
-
- # Restore our entire environment from start time.
- # We need it to evaluate the editor, and the editor
- # may want stuff from it as well, like TERM.
- array unset env_save; array set env_save [array get env]
- array unset env *
- if {${macports::macosx_version} eq "10.5"} {
- unsetenv *
- }
- array set env [array get boot_env]
-
- # Find an editor to edit the portfile
- set editor ""
- set editor_var "ports_${action}_editor"
- if {[info exists local_options($editor_var)]} {
- set editor [join $local_options($editor_var)]
- } else {
- foreach ed { MP_EDITOR VISUAL EDITOR } {
- if {[info exists env($ed)]} {
- set editor $env($ed)
- break
- }
- }
- }
-
- # Use a reasonable canned default if no editor specified or set in env
- if { $editor eq "" } { set editor "/usr/bin/vi" }
-
- # Invoke the editor
- if {[catch {eval exec >@stdout <@stdin 2>@stderr $editor {$portfile}} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "unable to invoke editor $editor: $result" 1 status
- }
-
- # Restore internal MacPorts environment
- array unset env *
- if {${macports::macosx_version} eq "10.5"} {
- unsetenv *
- }
- array set env [array get env_save]
- }
-
- dir {
- # output the path to the port's directory
- puts $portdir
- }
-
- work {
- # output the path to the port's work directory
- set workpath [macports::getportworkpath_from_portdir $portdir $portname]
- if {[file exists $workpath]} {
- puts $workpath
- }
- }
-
- cd {
- # Change to the port's directory, making it the default
- # port for any future commands
- set current_portdir $portdir
- }
-
- url {
- # output the url of the port's directory, suitable to feed back in later as a port descriptor
- puts $porturl
- }
-
- file {
- # output the path to the port's portfile
- puts $portfile
- }
-
- logfile {
- set logfile [file join [macports::getportlogpath $portdir $portname] "main.log"]
- if {[file isfile $logfile]} {
- puts $logfile
- } else {
- ui_error "Log file not found for port in $portdir"
- }
- }
-
- gohome {
- set homepage ""
-
- # Get the homepage as read from PortIndex
- if {[info exists portinfo(homepage)]} {
- set homepage $portinfo(homepage)
- }
-
- # If not available, get the homepage for the port by opening the Portfile
- if {$homepage eq "" && ![catch {set ctx [mportopen $porturl]} result]} {
- array set portinfo [mportinfo $ctx]
- if {[info exists portinfo(homepage)]} {
- set homepage $portinfo(homepage)
- }
- mportclose $ctx
- }
-
- # Try to open a browser to the homepage for the given port
- if { $homepage ne "" } {
- if {[catch {system "${macports::autoconf::open_path} '$homepage'"} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "unable to invoke browser using ${macports::autoconf::open_path}: $result" 1 status
- }
- } else {
- ui_error [format "No homepage for %s" $portname]
- }
- }
- }
- } else {
- break_softcontinue "Could not read $portfile" 1 status
- }
- }
-
- return $status
-}
-
-
-proc action_sync { action portlist opts } {
- global global_options
-
- set status 0
- if {[catch {mportsync [array get global_options]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- ui_msg "port sync failed: $result"
- set status 1
- }
-
- return $status
-}
-
-
-proc action_target { action portlist opts } {
- global global_variations
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
- if {($action eq "install" || $action eq "archive") && [prefix_unwritable] && ![macports::global_option_isset ports_dryrun]} {
- return 1
- }
- foreachport $portlist {
- array unset portinfo
- # If we have a url, use that, since it's most specific
- # otherwise try to map the portname to a url
- if {$porturl eq ""} {
- # Verify the portname, getting portinfo to map to a porturl
- if {[catch {set res [mportlookup $portname]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $res] < 2} {
- # don't error for ports that are installed but not in the tree
- if {[registry::entry_exists_for_name $portname]} {
- ui_warn "Skipping $portname (not in the ports tree)"
- continue
- } else {
- break_softcontinue "Port $portname not found" 1 status
- }
- }
- array set portinfo [lindex $res 1]
- set porturl $portinfo(porturl)
- }
-
- # use existing variants iff none were explicitly requested
- if {[array get requested_variations] eq "" && [array get variations] ne ""} {
- array unset requested_variations
- array set requested_variations [array get variations]
- }
-
- # Add any global_variations to the variations
- # specified for the port
- foreach { variation value } [array get global_variations] {
- if { ![info exists requested_variations($variation)] } {
- set requested_variations($variation) $value
- }
- }
-
- # If version was specified, save it as a version glob for use
- # in port actions (e.g. clean).
- if {[string length $portversion]} {
- set options(ports_version_glob) $portversion
- }
- # if installing, mark the port as explicitly requested
- if {$action eq "install"} {
- if {![info exists options(ports_install_unrequested)]} {
- set options(ports_requested) 1
- }
- # we actually activate as well
- set target activate
- } elseif {$action eq "archive"} {
- set target install
- } else {
- set target $action
- }
- if {![info exists options(subport)]} {
- if {[info exists portinfo(name)]} {
- set options(subport) $portinfo(name)
- } else {
- set options(subport) $portname
- }
- }
- if {[catch {set workername [mportopen $porturl [array get options] [array get requested_variations]]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "Unable to open port: $result" 1 status
- }
- if {[catch {set result [mportexec $workername $target]} result]} {
- global errorInfo
- mportclose $workername
- ui_debug "$errorInfo"
- break_softcontinue "Unable to execute port: $result" 1 status
- }
-
- mportclose $workername
-
- # Process any error that wasn't thrown and handled already
- if {$result} {
- print_tickets_url
- break_softcontinue "Processing of port $portname failed" 1 status
- }
- }
-
- if {$status == 0 && $action eq "install" && ![macports::global_option_isset ports_dryrun]} {
- array set options $opts
- if {![info exists options(ports_nodeps)] && ![info exists options(ports_install_no-rev-upgrade)] && ${macports::revupgrade_autorun}} {
- set status [action_revupgrade $action $portlist $opts]
- }
- }
-
- return $status
-}
-
-
-proc action_exit { action portlist opts } {
- # Return a semaphore telling the main loop to quit
- return -999
-}
-
-
-##########################################
-# Command Parsing
-##########################################
-proc moreargs {} {
- global cmd_argn cmd_argc
- return [expr {$cmd_argn < $cmd_argc}]
-}
-
-
-proc lookahead {} {
- global cmd_argn cmd_argc cmd_argv
- if {$cmd_argn < $cmd_argc} {
- return [lindex $cmd_argv $cmd_argn]
- } else {
- return _EOF_
- }
-}
-
-
-proc advance {} {
- global cmd_argn
- incr cmd_argn
-}
-
-
-proc match s {
- if {[lookahead] == $s} {
- advance
- return 1
- }
- return 0
-}
-
-# action_array specifies which action to run on the given command
-# and if the action wants an expanded portlist.
-# The value is a list of the form {action expand},
-# where action is a string and expand a value:
-# 0 none Does not expect any text argument
-# 1 strings Expects some strings as text argument
-# 2 ports Wants an expanded list of ports as text argument
-global action_array
-
-# Define global constants
-const ACTION_ARGS_NONE 0
-const ACTION_ARGS_STRINGS 1
-const ACTION_ARGS_PORTS 2
-
-array set action_array [list \
- usage [list action_usage [ACTION_ARGS_STRINGS]] \
- help [list action_help [ACTION_ARGS_STRINGS]] \
- \
- echo [list action_echo [ACTION_ARGS_PORTS]] \
- \
- info [list action_info [ACTION_ARGS_PORTS]] \
- location [list action_location [ACTION_ARGS_PORTS]] \
- notes [list action_notes [ACTION_ARGS_PORTS]] \
- provides [list action_provides [ACTION_ARGS_STRINGS]] \
- log [list action_log [ACTION_ARGS_PORTS]] \
- \
- activate [list action_activate [ACTION_ARGS_PORTS]] \
- deactivate [list action_deactivate [ACTION_ARGS_PORTS]] \
- \
- select [list action_select [ACTION_ARGS_STRINGS]] \
- \
- sync [list action_sync [ACTION_ARGS_NONE]] \
- selfupdate [list action_selfupdate [ACTION_ARGS_NONE]] \
- \
- setrequested [list action_setrequested [ACTION_ARGS_PORTS]] \
- unsetrequested [list action_setrequested [ACTION_ARGS_PORTS]] \
- \
- upgrade [list action_upgrade [ACTION_ARGS_PORTS]] \
- rev-upgrade [list action_revupgrade [ACTION_ARGS_NONE]] \
- reclaim [list action_reclaim [ACTION_ARGS_NONE]] \
- \
- version [list action_version [ACTION_ARGS_NONE]] \
- platform [list action_platform [ACTION_ARGS_NONE]] \
- \
- uninstall [list action_uninstall [ACTION_ARGS_PORTS]] \
- \
- installed [list action_installed [ACTION_ARGS_PORTS]] \
- outdated [list action_outdated [ACTION_ARGS_PORTS]] \
- contents [list action_contents [ACTION_ARGS_PORTS]] \
- space [list action_space [ACTION_ARGS_PORTS]] \
- dependents [list action_dependents [ACTION_ARGS_PORTS]] \
- rdependents [list action_dependents [ACTION_ARGS_PORTS]] \
- deps [list action_deps [ACTION_ARGS_PORTS]] \
- rdeps [list action_deps [ACTION_ARGS_PORTS]] \
- variants [list action_variants [ACTION_ARGS_PORTS]] \
- \
- search [list action_search [ACTION_ARGS_STRINGS]] \
- list [list action_list [ACTION_ARGS_PORTS]] \
- \
- edit [list action_portcmds [ACTION_ARGS_PORTS]] \
- cat [list action_portcmds [ACTION_ARGS_PORTS]] \
- dir [list action_portcmds [ACTION_ARGS_PORTS]] \
- work [list action_portcmds [ACTION_ARGS_PORTS]] \
- cd [list action_portcmds [ACTION_ARGS_PORTS]] \
- url [list action_portcmds [ACTION_ARGS_PORTS]] \
- file [list action_portcmds [ACTION_ARGS_PORTS]] \
- logfile [list action_portcmds [ACTION_ARGS_PORTS]] \
- gohome [list action_portcmds [ACTION_ARGS_PORTS]] \
- \
- fetch [list action_target [ACTION_ARGS_PORTS]] \
- checksum [list action_target [ACTION_ARGS_PORTS]] \
- extract [list action_target [ACTION_ARGS_PORTS]] \
- patch [list action_target [ACTION_ARGS_PORTS]] \
- configure [list action_target [ACTION_ARGS_PORTS]] \
- build [list action_target [ACTION_ARGS_PORTS]] \
- destroot [list action_target [ACTION_ARGS_PORTS]] \
- install [list action_target [ACTION_ARGS_PORTS]] \
- clean [list action_target [ACTION_ARGS_PORTS]] \
- test [list action_target [ACTION_ARGS_PORTS]] \
- lint [list action_target [ACTION_ARGS_PORTS]] \
- livecheck [list action_target [ACTION_ARGS_PORTS]] \
- distcheck [list action_target [ACTION_ARGS_PORTS]] \
- mirror [list action_target [ACTION_ARGS_PORTS]] \
- load [list action_target [ACTION_ARGS_PORTS]] \
- unload [list action_target [ACTION_ARGS_PORTS]] \
- distfiles [list action_target [ACTION_ARGS_PORTS]] \
- \
- archivefetch [list action_target [ACTION_ARGS_PORTS]] \
- archive [list action_target [ACTION_ARGS_PORTS]] \
- unarchive [list action_target [ACTION_ARGS_PORTS]] \
- dmg [list action_target [ACTION_ARGS_PORTS]] \
- mdmg [list action_target [ACTION_ARGS_PORTS]] \
- dpkg [list action_target [ACTION_ARGS_PORTS]] \
- mpkg [list action_target [ACTION_ARGS_PORTS]] \
- pkg [list action_target [ACTION_ARGS_PORTS]] \
- portpkg [list action_target [ACTION_ARGS_PORTS]] \
- rpm [list action_target [ACTION_ARGS_PORTS]] \
- srpm [list action_target [ACTION_ARGS_PORTS]] \
- \
- quit [list action_exit [ACTION_ARGS_NONE]] \
- exit [list action_exit [ACTION_ARGS_NONE]] \
-]
-
-# Expand "action".
-# Returns an action proc, or a list of matching action procs, or the action passed in
-proc find_action { action } {
- global action_array
-
- if { ! [info exists action_array($action)] } {
- set guess [guess_action $action]
- if { [info exists action_array($guess)] } {
- return $guess
- }
- return $guess
- }
-
- return $action
-}
-
-# Expand action
-# If there's more than one match, return the next possibility
-proc find_action_proc { action } {
- global action_array
-
- set action_proc ""
- if { [info exists action_array($action)] } {
- set action_proc [lindex $action_array($action) 0]
- } else {
- set action [complete_action $action]
- if { [info exists action_array($action)] } {
- set action_proc [lindex $action_array($action) 0]
- }
- }
-
- return $action_proc
-}
-
-proc get_action_proc { action } {
- global action_array
-
- set action_proc ""
- if { [info exists action_array($action)] } {
- set action_proc [lindex $action_array($action) 0]
- }
-
- return $action_proc
-}
-
-# Returns whether an action expects text arguments at all,
-# expects text arguments or wants an expanded list of ports
-# Return values are constants:
-# [ACTION_ARGS_NONE] Does not expect any text argument
-# [ACTION_ARGS_STRINGS] Expects some strings as text argument
-# [ACTION_ARGS_PORTS] Wants an expanded list of ports as text argument
-proc action_needs_portlist { action } {
- global action_array
-
- set ret 0
- if {[info exists action_array($action)]} {
- set ret [lindex $action_array($action) 1]
- }
-
- return $ret
-}
-
-# cmd_opts_array specifies which arguments the commands accept
-# Commands not listed here do not accept any arguments
-# Syntax if {option argn}
-# Where option is the name of the option and argn specifies how many arguments
-# this argument takes
-global cmd_opts_array
-array set cmd_opts_array {
- edit {{editor 1}}
- info {category categories depends_fetch depends_extract
- depends_build depends_lib depends_run
- depends description epoch fullname heading homepage index license
- line long_description
- maintainer maintainers name platform platforms portdir pretty
- replaced_by revision subports variant variants version}
- contents {size {units 1}}
- deps {index no-build}
- rdeps {index no-build full}
- rdependents {full}
- search {case-sensitive category categories depends_fetch
- depends_extract depends_build depends_lib depends_run
- depends description epoch exact glob homepage line
- long_description maintainer maintainers name platform
- platforms portdir regex revision variant variants version}
- selfupdate {nosync}
- space {{units 1} total}
- activate {no-exec}
- deactivate {no-exec}
- install {no-rev-upgrade unrequested}
- uninstall {follow-dependents follow-dependencies no-exec}
- variants {index}
- clean {all archive dist work logs gsoc14}
- mirror {new}
- lint {nitpick}
- select {list set show summary}
- log {{phase 1} {level 1}}
- upgrade {force enforce-variants no-replace no-rev-upgrade}
- rev-upgrade {id-loadcmd-check}
-}
-
-##
-# Checks whether the given option is valid
-#
-# @param action for which action
-# @param option the prefix of the option to check
-# @return list of pairs {name argc} for all matching options
-proc cmd_option_matches {action option} {
- global cmd_opts_array
-
- # This could be so easy with lsearch -index,
- # but that's only available as of Tcl 8.5
-
- if {![info exists cmd_opts_array($action)]} {
- return {}
- }
-
- set result {}
-
- foreach item $cmd_opts_array($action) {
- if {[llength $item] == 1} {
- set name $item
- set argc 0
- } else {
- set name [lindex $item 0]
- set argc [lindex $item 1]
- }
-
- if {$name == $option} {
- set result [list [list $name $argc]]
- break
- } elseif {[string first $option $name] == 0} {
- lappend result [list $name $argc]
- }
- }
-
- return $result
-}
-
-# Parse global options
-#
-# Note that this is called several times:
-# (1) Initially, to parse options that will be constant across all commands
-# (options that come prior to any command, frozen into global_options_base)
-# (2) Following each command (to parse options that will be unique to that command
-# (the global_options array is reset to global_options_base prior to each command)
-#
-proc parse_options { action ui_options_name global_options_name } {
- upvar $ui_options_name ui_options
- upvar $global_options_name global_options
- global cmdname cmd_opts_array
-
- while {[moreargs]} {
- set arg [lookahead]
-
- if {[string index $arg 0] ne "-"} {
- break
- } elseif {[string index $arg 1] eq "-"} {
- # Process long arguments
- switch -- $arg {
- -- { # This is the options terminator; do no further option processing
- advance; break
- }
- default {
- set key [string range $arg 2 end]
- set kopts [cmd_option_matches $action $key]
- if {[llength $kopts] == 0} {
- return -code error "${action} does not accept --${key}"
- } elseif {[llength $kopts] > 1} {
- set errlst {}
- foreach e $kopts {
- lappend errlst "--[lindex $e 0]"
- }
- return -code error "\"port ${action} --${key}\" is ambiguous: \n port ${action} [join $errlst "\n port ${action} "]"
- }
- set key [lindex $kopts 0 0]
- set kargc [lindex $kopts 0 1]
- if {$kargc == 0} {
- set global_options(ports_${action}_${key}) yes
- } else {
- set args {}
- while {[moreargs] && $kargc > 0} {
- advance
- lappend args [lookahead]
- set kargc [expr {$kargc - 1}]
- }
- if {$kargc > 0} {
- return -code error "--${key} expects [expr {$kargc + [llength $args]}] parameters!"
- }
- set global_options(ports_${action}_${key}) $args
- }
- }
- }
- } else {
- # Process short arg(s)
- set opts [string range $arg 1 end]
- foreach c [split $opts {}] {
- switch -- $c {
- v {
- set ui_options(ports_verbose) yes
- }
- d {
- set ui_options(ports_debug) yes
- # debug implies verbose
- set ui_options(ports_verbose) yes
- }
- q {
- set ui_options(ports_quiet) yes
- }
- p {
- # Ignore errors while processing within a command
- set ui_options(ports_processall) yes
- }
- f {
- set global_options(ports_force) yes
- }
- o {
- set global_options(ports_ignore_different) yes
- }
- n {
- set global_options(ports_nodeps) yes
- }
- u {
- set global_options(port_uninstall_old) yes
- }
- R {
- set global_options(ports_do_dependents) yes
- }
- s {
- set global_options(ports_source_only) yes
- }
- b {
- set global_options(ports_binary_only) yes
- }
- c {
- set global_options(ports_autoclean) yes
- }
- k {
- set global_options(ports_autoclean) no
- }
- t {
- set global_options(ports_trace) yes
- }
- y {
- set global_options(ports_dryrun) yes
- }
- F {
- # Name a command file to process
- advance
- if {[moreargs]} {
- lappend ui_options(ports_commandfiles) [lookahead]
- }
- }
- D {
- advance
- if {[moreargs]} {
- cd [lookahead]
- }
- break
- }
- default {
- print_usage; exit 1
- }
- }
- }
- }
-
- advance
- }
-}
-
-# acquire exclusive registry lock for actions that need it
-# returns 1 if locked, 0 otherwise
-proc lock_reg_if_needed {action} {
- switch -- $action {
- activate -
- deactivate -
- setrequested -
- unsetrequested -
- upgrade -
- uninstall -
- install {
- registry::exclusive_lock
- return 1
- }
- }
- return 0
-}
-
-proc process_cmd { argv } {
- global cmd_argc cmd_argv cmd_argn \
- global_options global_options_base private_options ui_options \
- current_portdir
- set cmd_argv $argv
- set cmd_argc [llength $argv]
- set cmd_argn 0
-
- set action_status 0
-
- # Process an action if there is one
- while {($action_status == 0 || [macports::ui_isset ports_processall]) && [moreargs]} {
- set action [lookahead]
- advance
-
- # Handle command separator
- if { $action == ";" } {
- continue
- }
-
- # Handle a comment
- if { [string index $action 0] == "#" } {
- while { [moreargs] } { advance }
- break
- }
-
- set locked [lock_reg_if_needed $action]
- # Always start out processing an action in current_portdir
- cd $current_portdir
-
- # Reset global_options from base before each action, as we munge it just below...
- array unset global_options
- array set global_options $global_options_base
-
- # Find an action to execute
- set actions [find_action $action]
- if {[llength $actions] == 1} {
- set action [lindex $actions 0]
- set action_proc [get_action_proc $action]
- } else {
- if {[llength $actions] > 1} {
- ui_error "\"port ${action}\" is ambiguous: \n port [join $actions "\n port "]"
- } else {
- ui_error "Unrecognized action \"port $action\""
- }
- set action_status 1
- break
- }
-
- # Parse options that will be unique to this action
- # (to avoid abiguity with -variants and a default port, either -- must be
- # used to terminate option processing, or the pseudo-port current must be specified).
- if {[catch {parse_options $action ui_options global_options} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- ui_error $result
- set action_status 1
- break
- }
-
- # What kind of arguments does the command expect?
- set expand [action_needs_portlist $action]
-
- # Parse action arguments, setting a special flag if there were none
- # We otherwise can't tell the difference between arguments that evaluate
- # to the empty set, and the empty set itself.
- set portlist {}
- switch -- [lookahead] {
- ; -
- _EOF_ {
- set private_options(ports_no_args) yes
- }
- default {
- if {[ACTION_ARGS_NONE] == $expand} {
- ui_error "$action does not accept string arguments"
- set action_status 1
- break
- } elseif {[ACTION_ARGS_STRINGS] == $expand} {
- while { [moreargs] && ![match ";"] } {
- lappend portlist [lookahead]
- advance
- }
- } elseif {[ACTION_ARGS_PORTS] == $expand} {
- # Parse port specifications into portlist
- if {![portExpr portlist]} {
- ui_error "Improper expression syntax while processing parameters"
- set action_status 1
- break
- }
- }
- }
- }
-
- # execute the action
- set action_status [$action_proc $action $portlist [array get global_options]]
-
- # unlock if needed
- if {$locked} {
- registry::exclusive_unlock
- }
-
- # Print notifications of just-activated ports.
- portclient::notifications::display
-
- # semaphore to exit
- if {$action_status == -999} break
- }
-
- return $action_status
-}
-
-
-proc complete_portname { text state } {
- global complete_choices complete_position
-
- if {$state == 0} {
- set complete_position 0
- set complete_choices {}
-
- # Build a list of ports with text as their prefix
- if {[catch {set res [mportsearch "${text}*" false glob]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "search for portname $pattern failed: $result"
- }
- foreach {name info} $res {
- lappend complete_choices $name
- }
- }
-
- set word [lindex $complete_choices $complete_position]
- incr complete_position
-
- return $word
-}
-
-
-# return text action beginning with $text
-proc complete_action { text state } {
- global action_array complete_choices complete_position
-
- if {$state == 0} {
- set complete_position 0
- set complete_choices [array names action_array "[string tolower $text]*"]
- }
-
- set word [lindex $complete_choices $complete_position]
- incr complete_position
-
- return $word
-}
-
-# return all actions beginning with $text
-proc guess_action { text } {
- global action_array
-
- return [array names action_array "[string tolower $text]*"]
-
- if { [llength $complete_choices ] == 1 } {
- return [lindex $complete_choices 0]
- }
-
- return {}
-}
-
-proc attempt_completion { text word start end } {
- # If the word starts with '~', or contains '.' or '/', then use the build-in
- # completion to complete the word
- if { [regexp {^~|[/.]} $word] } {
- return ""
- }
-
- # Decide how to do completion based on where we are in the string
- set prefix [string range $text 0 [expr {$start - 1}]]
-
- # If only whitespace characters preceed us, or if the
- # previous non-whitespace character was a ;, then we're
- # an action (the first word of a command)
- if { [regexp {(^\s*$)|(;\s*$)} $prefix] } {
- return complete_action
- }
-
- # Otherwise, do completion on portname
- return complete_portname
-}
-
-
-proc get_next_cmdline { in out use_readline prompt linename } {
- upvar $linename line
-
- set line ""
- while { $line eq "" } {
-
- if {$use_readline} {
- set len [readline read -attempted_completion attempt_completion line $prompt]
- } else {
- puts -nonewline $out $prompt
- flush $out
- set len [gets $in line]
- }
-
- if { $len < 0 } {
- return -1
- }
-
- set line [string trim $line]
-
- if { $use_readline && $line ne "" } {
- rl_history add $line
- }
- }
-
- return [llength $line]
-}
-
-
-proc process_command_file { in } {
- global current_portdir
-
- # Initialize readline
- set isstdin [string match $in "stdin"]
- set name "port"
- set use_readline [expr {$isstdin && [readline init $name]}]
- set history_file [file normalize "${macports::macports_user_dir}/history"]
-
- # Read readline history
- if {$use_readline && [file isdirectory $macports::macports_user_dir]} {
- rl_history read $history_file
- rl_history stifle 100
- }
-
- # Be noisy, if appropriate
- set noisy [expr $isstdin && ![macports::ui_isset ports_quiet]]
- if { $noisy } {
- puts "MacPorts [macports::version]"
- puts "Entering interactive mode... (\"help\" for help, \"quit\" to quit)"
- }
-
- # Main command loop
- set exit_status 0
- while { $exit_status == 0 || $isstdin || [macports::ui_isset ports_processall] } {
-
- # Calculate our prompt
- if { $noisy } {
- set shortdir [eval file join [lrange [file split $current_portdir] end-1 end]]
- set prompt "\[$shortdir\] > "
- } else {
- set prompt ""
- }
-
- # Get a command line
- if { [get_next_cmdline $in stdout $use_readline $prompt line] <= 0 } {
- puts ""
- break
- }
-
- # Process the command
- set exit_status [process_cmd $line]
-
- # Check for semaphore to exit
- if {$exit_status == -999} {
- set exit_status 0
- break
- }
- }
-
- # Create macports user directory if it does not exist yet
- if {$use_readline && ![file isdirectory $macports::macports_user_dir]} {
- file mkdir $macports::macports_user_dir
- }
- # Save readine history
- if {$use_readline && [file isdirectory $macports::macports_user_dir]} {
- rl_history write $history_file
- }
-
- # Say goodbye
- if { $noisy } {
- puts "Goodbye"
- }
-
- return $exit_status
-}
-
-
-proc process_command_files { filelist } {
- set exit_status 0
-
- # For each file in the command list, process commands
- # in the file
- foreach file $filelist {
- if {$file eq "-"} {
- set in stdin
- } else {
- if {[catch {set in [open $file]} result]} {
- fatal "Failed to open command file; $result"
- }
- }
-
- set exit_status [process_command_file $in]
-
- if {$in ne "stdin"} {
- close $in
- }
-
- # Exit on first failure unless -p was given
- if {$exit_status != 0 && ![macports::ui_isset ports_processall]} {
- return $exit_status
- }
- }
-
- return $exit_status
-}
-
-namespace eval portclient::progress {
- ##
- # Maximum width of the progress bar or indicator when displaying it.
- variable maxWidth 50
-
- ##
- # The start time of the last progress callback as returned by [clock time].
- # Since only one progress indicator is active at a time, this variable is
- # shared between the different variants of progress functions.
- variable startTime
-
- ##
- # Delay in milliseconds after the start of the operation before deciding
- # that showing a progress bar makes sense.
- variable showTimeThreshold 500
-
- ##
- # Percentage value between 0 and 1 that must not have been reached yet when
- # $showTimeThreshold has passed for a progress bar to be shown. If the
- # operation has proceeded above e.g. 75% after 500ms we won't bother
- # displaying a progress indicator anymore -- the operation will be finished
- # in well below a second anyway.
- variable showPercentageThreshold 0.75
-
- ##
- # Boolean indication whether the progress indicator should be shown or is
- # still hidden because the current operation didn't need enough time for
- # a progress indicator to make sense, yet.
- variable show no
-
- ##
- # Initialize the progress bar display delay; call this from the start
- # action of the progress functions.
- proc initDelay {} {
- variable show
- variable startTime
-
- set startTime [clock milliseconds]
- set show no
- }
-
- ##
- # Determine whether a progress bar should be shown for the current
- # operation in its current state. You must have called initDelay for the
- # current operation before calling this method.
- #
- # @param cur
- # Current progress in abstract units.
- # @param total
- # Total number of abstract units to be processed, if known. Pass
- # 0 if unknown.
- # @return
- # "yes", if the progress indicator should be shown, "no" otherwise.
- proc showProgress {cur total} {
- variable show
- variable startTime
- variable showTimeThreshold
- variable showPercentageThreshold
-
- if {$show eq "yes"} {
- return yes
- } else {
- if {[expr {[clock milliseconds] - $startTime}] > $showTimeThreshold &&
- ($total == 0 || [expr {double($cur) / double($total)}] < $showPercentageThreshold)} {
- set show yes
- }
- return $show
- }
- }
-
- ##
- # Progress callback for generic operations executed by macports 1.0.
- #
- # @param action
- # One of "start", "update", "intermission" or "finish", where start
- # will be called before any number of update calls, interrupted by
- # any number of intermission calls (called because other output is
- # being produced), followed by one call to finish.
- # @param args
- # A list of variadic args that differ for each action. For "start",
- # "intermission" and "finish", the args are empty and unused. For
- # "update", args contains $cur and $total, where $cur is the current
- # number of units processed and $total is the total number of units
- # to be processed. If the total is not known, it is 0.
- proc generic {action args} {
- global env
- variable maxWidth
-
- switch -nocase -- $action {
- start {
- initDelay
- }
- update {
- # the for loop is a simple hack because Tcl 8.4 doesn't have
- # lassign
- foreach {now total} $args {
- if {[showProgress $now $total] eq "yes"} {
- set barPrefix " "
- set barPrefixLen [string length $barPrefix]
- if {$total != 0} {
- progressbar $now $total [expr {min($maxWidth, $env(COLUMNS) - $barPrefixLen)}] $barPrefix
- } else {
- unprogressbar [expr {min($maxWidth, $env(COLUMNS) - $barPrefixLen)}] $barPrefix
- }
- }
- }
- }
- intermission -
- finish {
- # erase to start of line
- ::term::ansi::send::esol
- # return cursor to start of line
- puts -nonewline "\r"
- flush stdout
- }
- }
-
- return 0
- }
-
- ##
- # Progress callback for downloads executed by macports 1.0.
- #
- # This is essentially a cURL progress callback.
- #
- # @param action
- # One of "start", "update" or "finish", where start will be called
- # before any number of update calls, followed by one call to finish.
- # @param args
- # A list of variadic args that differ for each action. For "start",
- # contains a single argument "ul" or "dl" indicating whether this is
- # an up- or download. For "update", contains the arguments
- # ("ul"|"dl") $total $now $speed where ul/dl are as for start, and
- # total, now and speed are doubles indicating the total transfer
- # size, currently transferred amount and average speed per second in
- # bytes. Unused for "finish".
- proc download {action args} {
- global env
- variable maxWidth
-
- switch -nocase -- $action {
- start {
- initDelay
- }
- update {
- # the for loop is a simple hack because Tcl 8.4 doesn't have
- # lassign
- foreach {type total now speed} $args {
- if {[showProgress $now $total] eq "yes"} {
- set barPrefix " "
- set barPrefixLen [string length $barPrefix]
- if {$total != 0} {
- set barSuffix [format " speed: %-13s" "[bytesize $speed {} "%.1f"]/s"]
- set barSuffixLen [string length $barSuffix]
-
- set barLen [expr {min($maxWidth, $env(COLUMNS) - $barPrefixLen - $barSuffixLen)}]
- progressbar $now $total $barLen $barPrefix $barSuffix
- } else {
- set barSuffix [format " %-10s speed: %-13s" [bytesize $now {} "%6.1f"] "[bytesize $speed {} "%.1f"]/s"]
- set barSuffixLen [string length $barSuffix]
-
- set barLen [expr {min($maxWidth, $env(COLUMNS) - $barPrefixLen - $barSuffixLen)}]
- unprogressbar $barLen $barPrefix $barSuffix
- }
- }
- }
- }
- finish {
- # erase to start of line
- ::term::ansi::send::esol
- # return cursor to start of line
- puts -nonewline "\r"
- flush stdout
- }
- }
-
- return 0
- }
-
- ##
- # Draw a progress bar using unicode block drawing characters
- #
- # @param current
- # The current progress value.
- # @param total
- # The progress value representing 100%.
- # @param width
- # The width in characters of the progress bar. This includes percentage
- # output, which takes up 8 characters.
- # @param prefix
- # Prefix to be printed in front of the progress bar.
- # @param suffix
- # Suffix to be printed after the progress bar.
- proc progressbar {current total width {prefix ""} {suffix ""}} {
- # Subtract the width of the percentage output, also subtract the two
- # characters [ and ] bounding the progress bar.
- set percentageWidth 8
- set barWidth [expr {entier($width) - $percentageWidth - 2}]
-
- # Map the range (0, $total) to (0, 4 * $width) where $width is the maximum
- # numebr of characters to be printed for the progress bar. Multiply the
- # upper bound with 8 because we have 8 sub-states per character.
- set barProgress [expr {entier(round(($current * $barWidth * 8) / $total))}]
-
- set barInteger [expr {$barProgress / 8}]
- #set barRemainder [expr {$barProgress % 8}]
-
- # Finally, also provide a percentage value to print behind the progress bar
- set percentage [expr {double($current) * 100 / double($total)}]
-
- # clear the current line, enable reverse video
- set progressbar "\033\[7m"
- for {set i 0} {$i < $barInteger} {incr i} {
- # U+2588 FULL BLOCK doesn't match the other blocks in some fonts :/
- # Two half blocks work better in some fonts, but not in others (because
- # they leave ugly spaces). So, one or the other choice isn't better or
- # worse and even just using full blocks looks ugly in a few fonts.
-
- # Use pure ASCII until somebody fixes most of the default terminal fonts :/
- append progressbar " "
- }
- # back to normal output
- append progressbar "\033\[0m"
-
- #switch $barRemainder {
- # 0 {
- # if {$barInteger < $barWidth} {
- # append progressbar " "
- # }
- # }
- # 1 {
- # # U+258F LEFT ONE EIGHTH BLOCK
- # append progressbar "\u258f"
- # }
- # 2 {
- # # U+258E LEFT ONE QUARTER BLOCK
- # append progressbar "\u258e"
- # }
- # 3 {
- # # U+258D LEFT THREE EIGHTHS BLOCK
- # append progressbar "\u258d"
- # }
- # 3 {
- # # U+258D LEFT THREE EIGHTHS BLOCK
- # append progressbar "\u258d"
- # }
- # 4 {
- # # U+258C LEFT HALF BLOCK
- # append progressbar "\u258c"
- # }
- # 5 {
- # # U+258B LEFT FIVE EIGHTHS BLOCK
- # append progressbar "\u258b"
- # }
- # 6 {
- # # U+258A LEFT THREE QUARTERS BLOCK
- # append progressbar "\u258a"
- # }
- # 7 {
- # # U+2589 LEFT SEVEN EIGHTHS BLOCK
- # append progressbar "\u2589"
- # }
- #}
-
- # Fill the progress bar with spaces
- for {set i $barInteger} {$i < $barWidth} {incr i} {
- append progressbar " "
- }
-
- # Format the percentage using the space that has been reserved for it
- set percentagesuffix [format " %[expr {$percentageWidth - 3}].1f %%" $percentage]
-
- puts -nonewline "\r${prefix}\[${progressbar}\]${percentagesuffix}${suffix}"
- flush stdout
- }
-
-
- ##
- # Internal state of the progress indicator; unless you're hacking the
- # unprogressbar code you should never touch this.
- variable unprogressState 0
-
- ##
- # Draw a progress indicator
- #
- # @param width
- # The width in characters of the progress indicator.
- # @param prefix
- # Prefix to be printed in front of the progress indicator.
- # @param suffix
- # Suffix to be printed after the progress indicator.
- proc unprogressbar {width {prefix ""} {suffix ""}} {
- variable unprogressState
-
- # Subtract the two characters [ and ] bounding the progress indicator
- # from the width.
- set barWidth [expr {int($width) - 2}]
-
- # Number of states of the progress bar, or rather: the number of
- # characters before the sequence repeats.
- set numStates 4
-
- set unprogressState [expr {($unprogressState + 1) % $numStates}]
-
- set progressbar ""
- for {set i 0} {$i < $barWidth} {incr i} {
- if {[expr {$i % $numStates}] == $unprogressState} {
- # U+2022 BULLET
- append progressbar "\u2022"
- } else {
- append progressbar " "
- }
- }
-
- puts -nonewline "\r${prefix}\[${progressbar}\]${suffix}"
- flush stdout
- }
-}
-
-namespace eval portclient::notifications {
- ##
- # Ports whose notifications to display; these were either installed
- # or requested to be installed.
- variable notificationsToPrint
- array set notificationsToPrint {}
-
- ##
- # Add a port to the list for printing notifications.
- #
- # @param name
- # The name of the port.
- # @param note
- # A list of notes to be stored for the given port.
- proc append {name notes} {
- variable notificationsToPrint
-
- set notificationsToPrint($name) $notes
- }
-
- ##
- # Print port notifications.
- #
- proc display {} {
- global env
- variable notificationsToPrint
-
- # Display notes at the end of the activation phase.
- if {[array size notificationsToPrint] > 0} {
- ui_notice "---> Some of the ports you installed have notes:"
- foreach {name notes} [array get notificationsToPrint] {
- ui_notice " $name has the following notes:"
-
- # If env(COLUMNS) exists, limit each line's width to this width.
- if {[info exists env(COLUMNS)]} {
- set maxlen $env(COLUMNS)
-
- foreach note $notes {
- foreach line [split $note "\n"] {
- set joiner ""
- set lines ""
- set newline " "
-
- foreach word [split $line " "] {
- if {[string length $newline] + [string length $word] >= $maxlen} {
- lappend lines $newline
- set newline " "
- set joiner ""
- }
- ::append newline $joiner $word
- set joiner " "
- }
- if {$newline ne {}} {
- lappend lines $newline
- }
- ui_notice [join $lines "\n"]
- }
- }
- } else {
- foreach note $notes {
- ui_notice $note
- }
- }
- }
- }
- }
-}
-
-
-##########################################
-# Main
-##########################################
-
-# Global arrays passed to the macports1.0 layer
-array set ui_options {}
-array set global_options {}
-array set global_variations {}
-
-# Global options private to this script
-array set private_options {}
-
-# Make sure we get the size of the terminal
-# We do this here to save it in the boot_env, in case we determined it manually
-term_init_size
-
-global env boot_env argv0 cmdname argc argv cmd_argc cmd_argv cmd_argn \
- current_portdir global_options_base exit_status
-
-# Save off a copy of the environment before mportinit monkeys with it
-array set boot_env [array get env]
-
-set cmdname [file tail $argv0]
-
-# Setp cmd_argv to match argv
-set cmd_argv $argv
-set cmd_argc $argc
-set cmd_argn 0
-
-# make sure we're using a sane umask
-umask 022
-
-# If we've been invoked as portf, then the first argument is assumed
-# to be the name of a command file (i.e., there is an implicit -F
-# before any arguments).
-if {[moreargs] && $cmdname eq "portf"} {
- lappend ui_options(ports_commandfiles) [lookahead]
- advance
-}
-
-# Parse global options that will affect all subsequent commands
-if {[catch {parse_options "global" ui_options global_options} result]} {
- puts "Error: $result"
- print_usage
- exit 1
-}
-
-if {[isatty stdout]
- && $portclient::progress::hasTermAnsiSend eq "yes"
- && (![info exists ui_options(ports_quiet)] || $ui_options(ports_quiet) ne "yes")} {
- set ui_options(progress_download) portclient::progress::download
- set ui_options(progress_generic) portclient::progress::generic
-}
-
-set ui_options(notifications_append) portclient::notifications::append
-
-# Get arguments remaining after option processing
-set remaining_args [lrange $cmd_argv $cmd_argn end]
-
-# If we have no arguments remaining after option processing then force
-# interactive mode
-if { [llength $remaining_args] == 0 && ![info exists ui_options(ports_commandfiles)] } {
- lappend ui_options(ports_commandfiles) -
-} elseif {[lookahead] eq "selfupdate" || [lookahead] eq "sync"} {
- # tell mportinit not to tell the user they should selfupdate
- set ui_options(ports_no_old_index_warning) 1
-}
-
-# Initialize mport
-# This must be done following parse of global options, as some options are
-# evaluated by mportinit.
-if {[catch {mportinit ui_options global_options global_variations} result]} {
- global errorInfo
- puts "$errorInfo"
- fatal "Failed to initialize MacPorts, $result"
-}
-
-# Set up some global state for our code
-set current_portdir [pwd]
-
-# Freeze global_options into global_options_base; global_options
-# will be reset to global_options_base prior to processing each command.
-set global_options_base [array get global_options]
-
-# First process any remaining args as action(s)
-set exit_status 0
-if { [llength $remaining_args] > 0 } {
-
- # If there are remaining arguments, process those as a command
- set exit_status [process_cmd $remaining_args]
-}
-
-# Process any prescribed command files, including standard input
-if { ($exit_status == 0 || [macports::ui_isset ports_processall]) && [info exists ui_options(ports_commandfiles)] } {
- set exit_status [process_command_files $ui_options(ports_commandfiles)]
-}
-if {$exit_status == -999} {
- set exit_status 0
-}
-
-# shut down macports1.0
-mportshutdown
-
-# Return with exit_status
-exit $exit_status
Deleted: branches/gsoc14-cleanup/src/port/port.LOCAL.23878
===================================================================
--- branches/gsoc14-cleanup/src/port/port.LOCAL.23878 2014-08-13 22:14:51 UTC (rev 123747)
+++ branches/gsoc14-cleanup/src/port/port.LOCAL.23878 2014-08-13 22:14:53 UTC (rev 123748)
@@ -1,5348 +0,0 @@
-#!/opt/local/libexec/macports/bin/tclsh8.5
-# -*- coding: utf-8; mode: tcl; tab-width: 4; indent-tabs-mode: nil; c-basic-offset: 4 -*- vim:fenc=utf-8:filetype=tcl:et:sw=4:ts=4:sts=4
-# $Id: port.tcl 119177 2014-04-18 22:35:29Z cal at macports.org $
-#
-# Copyright (c) 2004-2014 The MacPorts Project
-# Copyright (c) 2004 Robert Shaw <rshaw at opendarwin.org>
-# Copyright (c) 2002-2003 Apple 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 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.
-
-# Create a namespace for some local variables
-namespace eval portclient::progress {
- ##
- # Indicate whether the term::ansi::send tcllib package is available and was
- # imported. "yes", if the package is available, "no" otherwise.
- variable hasTermAnsiSend no
-}
-
-if {![catch {package require term::ansi::send}]} {
- set portclient::progress::hasTermAnsiSend yes
-}
-
-package require macports
-package require Pextlib 1.0
-
-# Standard procedures
-proc print_usage {{verbose 1}} {
- global cmdname
- set syntax {
- [-bcdfknopqRstuvy] [-D portdir] [-F cmdfile] action [privopts] [actionflags]
- [[portname|pseudo-portname|port-url] [@version] [+-variant]... [option=value]...]...
- }
-
- if {$verbose} {
- puts stderr "Usage: $cmdname$syntax"
- puts stderr "\"$cmdname help\" or \"man 1 port\" for more information."
- } else {
- puts stderr "$cmdname$syntax"
- }
-}
-
-proc print_help {args} {
- global action_array
-
- print_usage 0
-
- # Generate and format the command list from the action_array
- set cmds ""
- set lineLen 0
- foreach cmd [lsort [array names action_array]] {
- if {$lineLen > 65} {
- set cmds "$cmds,\n"
- set lineLen 0
- }
- if {$lineLen == 0} {
- set new "$cmd"
- } else {
- set new ", $cmd"
- }
- incr lineLen [string length $new]
- set cmds "$cmds$new"
- }
-
- set cmdText "Supported actions
-------------------
-$cmds
-"
-
- set text {
-Pseudo-portnames
-----------------
-Pseudo-portnames are words that may be used in place of a portname, and
-which expand to some set of ports. The common pseudo-portnames are:
-all, current, active, inactive, actinact, installed, uninstalled, outdated,
-obsolete, requested, unrequested and leaves.
-These pseudo-portnames expand to the set of ports named.
-
-Pseudo-portnames starting with variants:, variant:, description:, depends:,
-depends_lib:, depends_run:, depends_build:, depends_fetch:, depends_extract:,
-portdir:, homepage:, epoch:, platforms:, platform:, name:, long_description:,
-maintainers:, maintainer:, categories:, category:, version:, revision:, and
-license: each select a set of ports based on a regex search of metadata
-about the ports. In all such cases, a standard regex pattern following
-the colon will be used to select the set of ports to which the
-pseudo-portname expands.
-
-Pseudo-portnames starting with depof:, rdepof:, dependentof:, and rdependentof:
-select ports that are direct or recursive dependencies or dependents of the
-following portname, respectively.
-
-Portnames that contain standard glob characters will be expanded to the
-set of ports matching the glob pattern.
-
-Port expressions
-----------------
-Portnames, port glob patterns, and pseudo-portnames may be logically
-combined using expressions consisting of and, or, not, !, (, and ).
-
-For more information
---------------------
-See man pages: port(1), macports.conf(5), portfile(7), portgroup(7),
-porthier(7), portstyle(7). Also, see http://www.macports.org.
- }
-
- puts "$cmdText$text"
-}
-
-
-# Produce error message and exit
-proc fatal s {
- global argv0
- ui_error "$argv0: $s"
- exit 1
-}
-
-##
-# Helper function to define constants
-#
-# Constants defined with const can simply be accessed in the same way as
-# calling a proc.
-#
-# Example:
-# const FOO 42
-# puts [FOO]
-#
-# @param name variable name
-# @param value constant variable value
-proc const {name args} {
- proc $name {} [list return [expr $args]]
-}
-
-# Format an integer representing bytes using given units
-proc bytesize {siz {unit {}} {format {%.3f}}} {
- if {$unit == {}} {
- if {$siz > 0x40000000} {
- set unit "GiB"
- } elseif {$siz > 0x100000} {
- set unit "MiB"
- } elseif {$siz > 0x400} {
- set unit "KiB"
- } else {
- set unit "B"
- }
- }
- switch -- $unit {
- KiB {
- set siz [expr {$siz / 1024.0}]
- }
- kB {
- set siz [expr {$siz / 1000.0}]
- }
- MiB {
- set siz [expr {$siz / 1048576.0}]
- }
- MB {
- set siz [expr {$siz / 1000000.0}]
- }
- GiB {
- set siz [expr {$siz / 1073741824.0}]
- }
- GB {
- set siz [expr {$siz / 1000000000.0}]
- }
- B { }
- default {
- ui_warn "Unknown file size unit '$unit' specified"
- set unit "B"
- }
- }
- if {[expr {round($siz)}] != $siz} {
- set siz [format $format $siz]
- }
- return "$siz $unit"
-}
-
-proc filesize {fil {unit {}}} {
- set siz {@}
- catch {
- set siz [bytesize [file size $fil] $unit]
- }
- return $siz
-}
-
-# Produce an error message, and exit, unless
-# we're handling errors in a soft fashion, in which
-# case we continue
-proc fatal_softcontinue s {
- if {[macports::global_option_isset ports_force]} {
- ui_error $s
- return -code continue
- } else {
- fatal $s
- }
-}
-
-
-# Produce an error message, and break, unless
-# we're handling errors in a soft fashion, in which
-# case we continue
-proc break_softcontinue { msg status name_status } {
- upvar $name_status status_var
- ui_error $msg
- if {[macports::ui_isset ports_processall]} {
- set status_var 0
- return -code continue
- } else {
- set status_var $status
- return -code break
- }
-}
-
-# show the URL for the ticket reporting instructions
-proc print_tickets_url {args} {
- if {${macports::prefix} ne "/usr/local" && ${macports::prefix} ne "/usr"} {
- ui_error "Follow http://guide.macports.org/#project.tickets to report a bug."
- }
-}
-
-# Form a composite version as is sometimes used for registry functions
-# This function sorts the variants and presents them in a canonical representation
-proc composite_version {version variations {emptyVersionOkay 0}} {
- # Form a composite version out of the version and variations
-
- # Select the variations into positive and negative
- set pos {}
- set neg {}
- foreach { key val } $variations {
- if {$val eq "+"} {
- lappend pos $key
- } elseif {$val eq "-"} {
- lappend neg $key
- }
- }
-
- # If there is no version, we have nothing to do
- set composite_version ""
- if {$version ne "" || $emptyVersionOkay} {
- set pos_str ""
- set neg_str ""
-
- if {[llength $pos]} {
- set pos_str "+[join [lsort -ascii $pos] "+"]"
- }
- if {[llength $neg]} {
- set neg_str "-[join [lsort -ascii $neg] "-"]"
- }
-
- set composite_version "$version$pos_str$neg_str"
- }
-
- return $composite_version
-}
-
-
-proc split_variants {variants} {
- set result {}
- set l [regexp -all -inline -- {([-+])([[:alpha:]_]+[\w\.]*)} $variants]
- foreach { match sign variant } $l {
- lappend result $variant $sign
- }
- return $result
-}
-
-
-##
-# Maps friendly field names to their real name
-# Names which do not need mapping are not changed.
-#
-# @param field friendly name
-# @return real name
-proc map_friendly_field_names { field } {
- switch -- $field {
- variant -
- platform -
- maintainer -
- subport {
- set field "${field}s"
- }
- category {
- set field "categories"
- }
- }
-
- return $field
-}
-
-
-proc registry_installed {portname {portversion ""}} {
- set ilist [registry::installed $portname $portversion]
- if { [llength $ilist] > 1 } {
- # set portname again since the one we were passed may not have had the correct case
- set portname [lindex $ilist 0 0]
- ui_notice "The following versions of $portname are currently installed:"
- foreach i [portlist_sortint $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 -code error "Registry error: Please specify the full version as recorded in the port registry."
- } else {
- return [lindex $ilist 0]
- }
-}
-
-
-proc entry_for_portlist {portentry} {
- global global_options global_variations
-
- # Each portlist entry currently has the following elements in it:
- # url if any
- # name
- # version (version_revision)
- # variants array (variant=>+-)
- # requested_variants array (variant=>+-)
- # options array (key=>value)
- # fullname (name/version_revision+-variants)
-
- array set port $portentry
- if {![info exists port(url)]} { set port(url) "" }
- if {![info exists port(name)]} { set port(name) "" }
- if {![info exists port(version)]} { set port(version) "" }
- if {![info exists port(variants)]} { set port(variants) "" }
- if {![info exists port(requested_variants)]} { set port(requested_variants) "" }
- if {![info exists port(options)]} { set port(options) [array get global_options] }
-
- # If neither portname nor url is specified, then default to the current port
- if { $port(url) eq "" && $port(name) eq "" } {
- set url file://.
- set portname [url_to_portname $url]
- set port(url) $url
- set port(name) $portname
- if {$portname eq ""} {
- ui_error "A default port name could not be supplied."
- }
- }
-
- # Form the fully discriminated portname: portname/version_revison+-variants
- set port(fullname) "$port(name)/[composite_version $port(version) $port(variants)]"
-
- return [array get port]
-}
-
-
-proc add_to_portlist {listname portentry} {
- upvar $listname portlist
-
- # Form portlist entry and add to portlist
- lappend portlist [entry_for_portlist $portentry]
-}
-
-
-proc add_ports_to_portlist {listname ports {overridelist ""}} {
- upvar $listname portlist
-
- array set overrides $overridelist
-
- # Add each entry to the named portlist, overriding any values
- # specified as overrides
- foreach portentry $ports {
- array set port $portentry
- if ([info exists overrides(version)]) { set port(version) $overrides(version) }
- if ([info exists overrides(variants)]) { set port(variants) $overrides(variants) }
- if ([info exists overrides(requested_variants)]) { set port(requested_variants) $overrides(requested_variants) }
- if ([info exists overrides(options)]) { set port(options) $overrides(options) }
- add_to_portlist portlist [array get port]
- }
-}
-
-
-proc url_to_portname { url {quiet 0} } {
- # Save directory and restore the directory, since mportopen changes it
- set savedir [pwd]
- set portname ""
- if {[catch {set ctx [mportopen $url]} result]} {
- if {!$quiet} {
- ui_msg "Can't map the URL '$url' to a port description file (\"${result}\")."
- ui_msg "Please verify that the directory and portfile syntax are correct."
- }
- } else {
- array set portinfo [mportinfo $ctx]
- set portname $portinfo(name)
- mportclose $ctx
- }
- cd $savedir
- return $portname
-}
-
-
-# Supply a default porturl/portname if the portlist is empty
-proc require_portlist { nameportlist {is_upgrade "no"} } {
- global private_options
- upvar $nameportlist portlist
-
- if {[llength $portlist] == 0 && (![info exists private_options(ports_no_args)] || $private_options(ports_no_args) eq "no")} {
- if {${is_upgrade} == "yes"} {
- # $> port upgrade outdated
- # Error: No ports matched the given expression
- # is not very user friendly - if we're in the special case of
- # "upgrade", let's print a message that's a little easier to
- # understand and less alarming.
- ui_msg "Nothing to upgrade."
- return 1
- }
- ui_error "No ports matched the given expression"
- return 1
- }
-
- if {[llength $portlist] == 0} {
- set portlist [get_current_port]
-
- if {[llength $portlist] == 0} {
- # there was no port in current directory
- return 1
- }
- }
-
- return 0
-}
-
-
-# Execute the enclosed block once for every element in the portlist
-# When the block is entered, the following variables will have been set:
-# portspec, porturl, portname, portversion, options, variations, requested_variations
-proc foreachport {portlist block} {
- set savedir [pwd]
- foreach portspec $portlist {
-
- # Set the variables for the block
- uplevel 1 "array unset portspec; array set portspec { $portspec }"
- uplevel 1 {
- set porturl $portspec(url)
- set portname $portspec(name)
- set portversion $portspec(version)
- array unset variations
- array set variations $portspec(variants)
- array unset requested_variations
- array set requested_variations $portspec(requested_variants)
- array unset options
- array set options $portspec(options)
- }
-
- # Invoke block
- uplevel 1 $block
-
- # Restore cwd after each port, since mportopen changes it, and otherwise relative
- # urls would break on subsequent passes
- if {[file exists $savedir]} {
- cd $savedir
- } else {
- cd ~
- }
- }
-}
-
-
-proc portlist_compare { a b } {
- array set a_ $a
- array set b_ $b
- set namecmp [string equal -nocase $a_(name) $b_(name)]
- if {$namecmp != 1} {
- if {$a_(name) eq [lindex [lsort -dictionary [list $a_(name) $b_(name)]] 0]} {
- return -1
- }
- return 1
- }
- set avr_ [split $a_(version) "_"]
- set bvr_ [split $b_(version) "_"]
- set versioncmp [vercmp [lindex $avr_ 0] [lindex $bvr_ 0]]
- if {$versioncmp != 0} {
- return $versioncmp
- }
- set ar_ [lindex $avr_ 1]
- set br_ [lindex $bvr_ 1]
- if {$ar_ < $br_} {
- return -1
- } elseif {$ar_ > $br_} {
- return 1
- } else {
- return 0
- }
-}
-
-# Sort two ports in NVR (name at version_revision) order
-proc portlist_sort { list } {
- return [lsort -command portlist_compare $list]
-}
-
-proc portlist_compareint { a b } {
- array set a_ [list "name" [lindex $a 0] "version" "[lindex $a 1]_[lindex $a 2]"]
- array set b_ [list "name" [lindex $b 0] "version" "[lindex $b 1]_[lindex $b 2]"]
- return [portlist_compare [array get a_] [array get b_]]
-}
-
-# Same as portlist_sort, but with numeric indexes {name version revision}
-proc portlist_sortint { list } {
- return [lsort -command portlist_compareint $list]
-}
-
-# sort portlist so dependents come before their dependencies
-proc portlist_sortdependents { portlist } {
- foreach p $portlist {
- array set pvals $p
- lappend entries($pvals(name)) $p
- if {![info exists dependents($pvals(name))]} {
- set dependents($pvals(name)) {}
- foreach result [registry::list_dependents $pvals(name)] {
- lappend dependents($pvals(name)) [lindex $result 2]
- }
- }
- array unset pvals
- }
- set ret {}
- foreach p $portlist {
- portlist_sortdependents_helper $p entries dependents seen ret
- }
- return $ret
-}
-
-proc portlist_sortdependents_helper {p up_entries up_dependents up_seen up_retlist} {
- upvar $up_seen seen
- if {![info exists seen($p)]} {
- set seen($p) 1
- upvar $up_entries entries $up_dependents dependents $up_retlist retlist
- array set pvals $p
- foreach dependent $dependents($pvals(name)) {
- if {[info exists entries($dependent)]} {
- foreach entry $entries($dependent) {
- portlist_sortdependents_helper $entry entries dependents seen retlist
- }
- }
- }
- lappend retlist $p
- }
-}
-
-proc regex_pat_sanitize { s } {
- set sanitized [regsub -all {[\\(){}+$.^]} $s {\\&}]
- return $sanitized
-}
-
-##
-# Makes sure we get the current terminal size
-proc term_init_size {} {
- global env
-
- if {![info exists env(COLUMNS)] || ![info exists env(LINES)]} {
- if {[isatty stdout]} {
- set size [term_get_size stdout]
-
- if {![info exists env(LINES)] && [lindex $size 0] > 0} {
- set env(LINES) [lindex $size 0]
- }
-
- if {![info exists env(COLUMNS)] && [lindex $size 1] > 0} {
- set env(COLUMNS) [lindex $size 1]
- }
- }
- }
-}
-
-##
-# Wraps a multi-line string at specified textwidth
-#
-# @see wrapline
-#
-# @param string input string
-# @param maxlen text width (0 defaults to current terminal width)
-# @param indent prepend to every line
-# @return wrapped string
-proc wrap {string maxlen {indent ""} {indentfirstline 1}} {
- global env
-
- if {$maxlen == 0} {
- if {![info exists env(COLUMNS)]} {
- # no width for wrapping
- return $string
- }
- set maxlen $env(COLUMNS)
- }
-
- set splitstring {}
- set indentline $indentfirstline
- foreach line [split $string "\n"] {
- lappend splitstring [wrapline $line $maxlen $indent $indentline]
- set indentline 1
- }
- return [join $splitstring "\n"]
-}
-
-##
-# Wraps a line at specified textwidth
-#
-# @see wrap
-#
-# @param line input line
-# @param maxlen text width (0 defaults to current terminal width)
-# @param indent prepend to every line
-# @return wrapped string
-proc wrapline {line maxlen {indent ""} {indentfirstline 1}} {
- global env
-
- if {$maxlen == 0} {
- if {![info exists env(COLUMNS)]} {
- # no width for wrapping
- return $string
- }
- set maxlen $env(COLUMNS)
- }
-
- set string [split $line " "]
- if {$indentfirstline == 0} {
- set newline ""
- set maxlen [expr {$maxlen - [string length $indent]}]
- } else {
- set newline $indent
- }
- append newline [lindex $string 0]
- set joiner " "
- set first 1
- foreach word [lrange $string 1 end] {
- if {[string length $newline]+[string length $word] >= $maxlen} {
- lappend lines $newline
- set newline $indent
- set joiner ""
- # If indentfirstline is set to 0, reset maxlen to its
- # original length after appending the first line to lines.
- if {$first == 1 && $indentfirstline == 0} {
- set maxlen [expr {$maxlen + [string length $indent]}]
- }
- set first 0
- }
- append newline $joiner $word
- set joiner " "
- }
- lappend lines $newline
- return [join $lines "\n"]
-}
-
-##
-# Wraps a line at a specified width with a label in front
-#
-# @see wrap
-#
-# @param label label for output
-# @param string input string
-# @param maxlen text width (0 defaults to current terminal width)
-# @return wrapped string
-proc wraplabel {label string maxlen {indent ""}} {
- append label ": [string repeat " " [expr {[string length $indent] - [string length "$label: "]}]]"
- return "$label[wrap $string $maxlen $indent 0]"
-}
-
-proc unobscure_maintainers { list } {
- set result {}
- foreach m $list {
- if {[string first "@" $m] < 0} {
- if {[string first ":" $m] >= 0} {
- set m [regsub -- "(.*):(.*)" $m "\\2@\\1"]
- } else {
- set m "$m at macports.org"
- }
- }
- lappend result $m
- }
- return $result
-}
-
-
-##########################################
-# Port selection
-##########################################
-proc unique_results_to_portlist {infos} {
- set result {}
- array unset unique
- foreach {name info} $infos {
- array unset portinfo
- array set portinfo $info
-
- set portentry [entry_for_portlist [list url $portinfo(porturl) name $name]]
-
- array unset entry
- array set entry $portentry
-
- if {[info exists unique($entry(fullname))]} continue
- set unique($entry(fullname)) 1
-
- lappend result $portentry
- }
- return $result
-}
-
-
-proc get_matching_ports {pattern {casesensitive no} {matchstyle glob} {field name}} {
- if {[catch {set res [mportsearch $pattern $casesensitive $matchstyle $field]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "search for portname $pattern failed: $result"
- }
- set results [unique_results_to_portlist $res]
-
- # Return the list of all ports, sorted
- return [portlist_sort $results]
-}
-
-
-proc get_all_ports {} {
- global all_ports_cache
-
- if {![info exists all_ports_cache]} {
- if {[catch {set res [mportlistall]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "listing all ports failed: $result"
- }
- set results [unique_results_to_portlist $res]
- set all_ports_cache [portlist_sort $results]
- }
- return $all_ports_cache
-}
-
-
-proc get_current_ports {} {
- # This is just a synonym for get_current_port that
- # works with the regex in element
- return [get_current_port]
-}
-
-
-proc get_current_port {} {
- set url file://.
- set portname [url_to_portname $url]
- if {$portname eq ""} {
- ui_msg "To use the current port, you must be in a port's directory."
- return [list]
- }
-
- set results {}
- add_to_portlist results [list url $url name $portname]
- return $results
-}
-
-
-proc get_installed_ports { {ignore_active yes} {active yes} } {
- set ilist {}
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "port installed failed: $result"
- }
- }
-
- set results {}
- foreach i $ilist {
- set iname [lindex $i 0]
- set iversion [lindex $i 1]
- set irevision [lindex $i 2]
- set ivariants [split_variants [lindex $i 3]]
- set iactive [lindex $i 4]
-
- if { ${ignore_active} == "yes" || (${active} == "yes") == (${iactive} != 0) } {
- add_to_portlist results [list name $iname version "${iversion}_${irevision}" variants $ivariants]
- }
- }
-
- # Return the list of ports, sorted
- return [portlist_sort $results]
-}
-
-
-proc get_uninstalled_ports {} {
- # Return all - installed
- set all [get_all_ports]
- set installed [get_installed_ports]
- return [opComplement $all $installed]
-}
-
-
-proc get_active_ports {} {
- return [get_installed_ports no yes]
-}
-
-
-proc get_inactive_ports {} {
- return [get_installed_ports no no]
-}
-
-proc get_actinact_ports {} {
- set inactive_ports [get_inactive_ports]
- set active_ports [get_active_ports]
- set results {}
-
- foreach port $inactive_ports {
- array set portspec $port
- set portname $portspec(name)
- lappend inact($portname) $port
- }
-
- foreach port $active_ports {
- array set portspec $port
- set portname $portspec(name)
-
- if {[info exists inact($portname)]} {
- if {![info exists added_inact($portname)]} {
- foreach inact_spec $inact($portname) {
- lappend results $inact_spec
- }
- set added_inact($portname) 1
- }
- lappend results $port
- }
- }
- return $results
-}
-
-
-proc get_outdated_ports {} {
- # Get the list of installed ports
- set ilist {}
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "port installed failed: $result"
- }
- }
-
- # Now process the list, keeping only those ports that are outdated
- set results {}
- if { [llength $ilist] > 0 } {
- foreach i $ilist {
-
- # Get information about the installed port
- set portname [lindex $i 0]
- set installed_version [lindex $i 1]
- set installed_revision [lindex $i 2]
- set installed_compound "${installed_version}_${installed_revision}"
- set installed_variants [lindex $i 3]
-
- set is_active [lindex $i 4]
- if {$is_active == 0} continue
-
- set installed_epoch [lindex $i 5]
-
- # Get info about the port from the index
- if {[catch {set res [mportlookup $portname]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "lookup of portname $portname failed: $result"
- }
- if {[llength $res] < 2} {
- if {[macports::ui_isset ports_debug]} {
- puts stderr "$portname ($installed_compound is installed; the port was not found in the port index)"
- }
- continue
- }
- array unset portinfo
- array set portinfo [lindex $res 1]
-
- # Get information about latest available version and revision
- set latest_version $portinfo(version)
- set latest_revision 0
- if {[info exists portinfo(revision)] && $portinfo(revision) > 0} {
- set latest_revision $portinfo(revision)
- }
- set latest_compound "${latest_version}_${latest_revision}"
- set latest_epoch 0
- if {[info exists portinfo(epoch)]} {
- set latest_epoch $portinfo(epoch)
- }
-
- # Compare versions, first checking epoch, then version, then revision
- set comp_result 0
- if {$installed_version != $latest_version} {
- set comp_result [expr {$installed_epoch - $latest_epoch}]
- if { $comp_result == 0 } {
- set comp_result [vercmp $installed_version $latest_version]
- }
- }
- if { $comp_result == 0 } {
- set comp_result [expr {$installed_revision - $latest_revision}]
- }
- if {$comp_result == 0} {
- set regref [registry::open_entry $portname $installed_version $installed_revision $installed_variants $installed_epoch]
- set os_platform_installed [registry::property_retrieve $regref os_platform]
- set os_major_installed [registry::property_retrieve $regref os_major]
- if {$os_platform_installed ne "" && $os_platform_installed != 0
- && $os_major_installed ne "" && $os_major_installed != 0
- && ($os_platform_installed != ${macports::os_platform} || $os_major_installed != ${macports::os_major})} {
- set comp_result -1
- }
- }
-
- # Add outdated ports to our results list
- if { $comp_result < 0 } {
- add_to_portlist results [list name $portname version $installed_compound variants [split_variants $installed_variants]]
- }
- }
- }
-
- return [portlist_sort $results]
-}
-
-
-proc get_obsolete_ports {} {
- set ilist [get_installed_ports]
- set results {}
-
- foreach i $ilist {
- array set port $i
-
- if {[catch {mportlookup $port(name)} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
-
- if {[llength $result] < 2} {
- lappend results $i
- }
- }
-
- # Return the list of ports, already sorted
- return [portlist_sort $results]
-}
-
-# return ports that have registry property $propname set to $propval
-proc get_ports_with_prop {propname propval} {
- set ilist {}
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "port installed failed: $result"
- }
- }
-
- set results {}
- foreach i $ilist {
- set iname [lindex $i 0]
- set iversion [lindex $i 1]
- set irevision [lindex $i 2]
- set ivariants [lindex $i 3]
- set iepoch [lindex $i 5]
- set regref [registry::open_entry $iname $iversion $irevision $ivariants $iepoch]
- if {[registry::property_retrieve $regref $propname] == $propval} {
- add_to_portlist results [list name $iname version "${iversion}_${irevision}" variants [split_variants $ivariants]]
- }
- }
-
- # Return the list of ports, sorted
- return [portlist_sort $results]
-}
-
-proc get_requested_ports {} {
- return [get_ports_with_prop requested 1]
-}
-
-proc get_unrequested_ports {} {
- return [get_ports_with_prop requested 0]
-}
-
-proc get_leaves_ports {} {
- set ilist {}
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "port installed failed: $result"
- }
- }
- registry::open_dep_map
- set results {}
- foreach i $ilist {
- set iname [lindex $i 0]
- if {[registry::list_dependents $iname] eq ""} {
- add_to_portlist results [list name $iname version "[lindex $i 1]_[lindex $i 2]" variants [split_variants [lindex $i 3]]]
- }
- }
- return [portlist_sort [opIntersection $results [get_unrequested_ports]]]
-}
-
-proc get_dependent_ports {portname recursive} {
- registry::open_dep_map
- set deplist [registry::list_dependents $portname]
- # could return specific versions here using registry2.0 features
- set results {}
- foreach dep $deplist {
- add_to_portlist results [list name [lindex $dep 2]]
- }
-
- # actually do this iteratively to avoid hitting Tcl's recursion limit
- if {$recursive} {
- while 1 {
- set rportlist {}
- set newlist {}
- foreach dep $deplist {
- set depname [lindex $dep 2]
- if {![info exists seen($depname)]} {
- set seen($depname) 1
- set rdeplist [registry::list_dependents $depname]
- foreach rdep $rdeplist {
- lappend newlist $rdep
- add_to_portlist rportlist [list name [lindex $rdep 2]]
- }
- }
- }
- if {[llength $rportlist] > 0} {
- set results [opUnion $results $rportlist]
- set deplist $newlist
- } else {
- break
- }
- }
- }
-
- return [portlist_sort $results]
-}
-
-
-proc get_dep_ports {portname recursive} {
- global global_variations
-
- # look up portname
- if {[catch {mportlookup $portname} result]} {
- ui_debug "$::errorInfo"
- return -code error "lookup of portname $portname failed: $result"
- }
- if {[llength $result] < 2} {
- return -code error "Port $portname not found"
- }
- array unset portinfo
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
-
- # open portfile
- if {[catch {set mport [mportopen $porturl [list subport $portinfo(name)] [array get global_variations]]} result]} {
- ui_debug "$::errorInfo"
- return -code error "Unable to open port: $result"
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
-
- # gather its deps
- set results {}
- set deptypes {depends_fetch depends_extract depends_build depends_lib depends_run}
-
- set deplist {}
- foreach type $deptypes {
- if {[info exists portinfo($type)]} {
- foreach dep $portinfo($type) {
- add_to_portlist results [list name [lindex [split $dep :] end]]
- lappend deplist $dep
- }
- }
- }
-
- # actually do this iteratively to avoid hitting Tcl's recursion limit
- if {$recursive} {
- while 1 {
- set rportlist {}
- set newlist {}
- foreach dep $deplist {
- set depname [lindex [split $dep :] end]
- if {![info exists seen($depname)]} {
- set seen($depname) 1
-
- # look up the dep
- if {[catch {mportlookup $depname} result]} {
- ui_debug "$::errorInfo"
- return -code error "lookup of portname $depname failed: $result"
- }
- if {[llength $result] < 2} {
- ui_error "Port $depname not found"
- continue
- }
- array unset portinfo
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
-
- # open its portfile
- if {[catch {set mport [mportopen $porturl [list subport $portinfo(name)] [array get global_variations]]} result]} {
- ui_debug "$::errorInfo"
- ui_error "Unable to open port: $result"
- continue
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
-
- # collect its deps
- set rdeplist {}
- foreach type $deptypes {
- if {[info exists portinfo($type)]} {
- foreach rdep $portinfo($type) {
- add_to_portlist results [list name [lindex [split $rdep :] end]]
- lappend rdeplist $rdep
- }
- }
- }
-
- # add them to the lists
- foreach rdep $rdeplist {
- lappend newlist $rdep
- add_to_portlist rportlist [list name [lindex [split $rdep :] end]]
- }
- }
- }
- if {[llength $rportlist] > 0} {
- set results [opUnion $results $rportlist]
- set deplist $newlist
- } else {
- break
- }
- }
- }
-
- return [portlist_sort $results]
-}
-
-proc get_subports {portname} {
- global global_variations
-
- # look up portname
- if {[catch {mportlookup $portname} result]} {
- ui_debug "$::errorInfo"
- return -code error "lookup of portname $portname failed: $result"
- }
- if {[llength $result] < 2} {
- return -code error "Port $portname not found"
- }
- array unset portinfo
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
-
- # open portfile
- if {[catch {set mport [mportopen $porturl [list subport $portinfo(name)] [array get global_variations]]} result]} {
- ui_debug "$::errorInfo"
- return -code error "Unable to open port: $result"
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
-
- # gather its subports
- set results {}
-
- if {[info exists portinfo(subports)]} {
- foreach subport $portinfo(subports) {
- add_to_portlist results [list name $subport]
- }
- }
-
- return [portlist_sort $results]
-}
-
-
-##########################################
-# Port expressions
-##########################################
-proc portExpr { resname } {
- upvar $resname reslist
- set result [seqExpr reslist]
- return $result
-}
-
-
-proc seqExpr { resname } {
- upvar $resname reslist
-
- # Evaluate a sequence of expressions a b c...
- # These act the same as a or b or c
-
- set result 1
- while {$result} {
- switch -- [lookahead] {
- ; -
- ) -
- _EOF_ { break }
- }
-
- set blist {}
- set result [orExpr blist]
- if {$result} {
- # Calculate the union of result and b
- set reslist [opUnion $reslist $blist]
- }
- }
-
- return $result
-}
-
-
-proc orExpr { resname } {
- upvar $resname reslist
-
- set a [andExpr reslist]
- while ($a) {
- switch -- [lookahead] {
- or {
- advance
- set blist {}
- if {![andExpr blist]} {
- return 0
- }
-
- # Calculate a union b
- set reslist [opUnion $reslist $blist]
- }
- default {
- return $a
- }
- }
- }
-
- return $a
-}
-
-
-proc andExpr { resname } {
- upvar $resname reslist
-
- set a [unaryExpr reslist]
- while {$a} {
- switch -- [lookahead] {
- and {
- advance
-
- set blist {}
- set b [unaryExpr blist]
- if {!$b} {
- return 0
- }
-
- # Calculate a intersect b
- set reslist [opIntersection $reslist $blist]
- }
- default {
- return $a
- }
- }
- }
-
- return $a
-}
-
-
-proc unaryExpr { resname } {
- upvar $resname reslist
- set result 0
-
- switch -- [lookahead] {
- ! -
- not {
- advance
- set blist {}
- set result [unaryExpr blist]
- if {$result} {
- set all [get_all_ports]
- set reslist [opComplement $all $blist]
- }
- }
- default {
- set result [element reslist]
- }
- }
-
- return $result
-}
-
-
-proc element { resname } {
- upvar $resname reslist
- set el 0
-
- set url ""
- set name ""
- set version ""
- array unset requested_variants
- array unset options
-
- set token [lookahead]
- switch -regex -- $token {
- ^\\)$ -
- ^\; -
- ^_EOF_$ { # End of expression/cmd/file
- }
-
- ^\\($ { # Parenthesized Expression
- advance
- set el [portExpr reslist]
- if {!$el || ![match ")"]} {
- set el 0
- }
- }
-
- ^all(@.*)?$ -
- ^installed(@.*)?$ -
- ^uninstalled(@.*)?$ -
- ^active(@.*)?$ -
- ^inactive(@.*)?$ -
- ^actinact(@.*)?$ -
- ^leaves(@.*)?$ -
- ^outdated(@.*)?$ -
- ^obsolete(@.*)?$ -
- ^requested(@.*)?$ -
- ^unrequested(@.*)?$ -
- ^current(@.*)?$ {
- # A simple pseudo-port name
- advance
-
- # Break off the version component, if there is one
- regexp {^(\w+)(@.*)?} $token matchvar name remainder
-
- add_multiple_ports reslist [get_${name}_ports] $remainder
-
- set el 1
- }
-
- ^variants: -
- ^variant: -
- ^description: -
- ^portdir: -
- ^homepage: -
- ^epoch: -
- ^platforms: -
- ^platform: -
- ^name: -
- ^long_description: -
- ^maintainers: -
- ^maintainer: -
- ^categories: -
- ^category: -
- ^version: -
- ^depends_lib: -
- ^depends_build: -
- ^depends_run: -
- ^depends_extract: -
- ^depends_fetch: -
- ^replaced_by: -
- ^revision: -
- ^subport: -
- ^subports: -
- ^license: { # Handle special port selectors
- advance
-
- # Break up the token, because older Tcl switch doesn't support -matchvar
- regexp {^(\w+):(.*)} $token matchvar field pat
-
- # Remap friendly names to actual names
- set field [map_friendly_field_names $field]
-
- add_multiple_ports reslist [get_matching_ports $pat no regexp $field]
- set el 1
- }
-
- ^depends: { # A port selector shorthand for depends_{lib,build,run,fetch,extract}
- advance
-
- # Break up the token, because older Tcl switch doesn't support -matchvar
- regexp {^(\w+):(.*)} $token matchvar field pat
-
- add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_lib"]
- add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_build"]
- add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_run"]
- add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_extract"]
- add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_fetch"]
-
- set el 1
- }
-
- ^dependentof: -
- ^rdependentof: {
- advance
-
- # Break up the token, because older Tcl switch doesn't support -matchvar
- regexp {^(\w+):(.*)} $token matchvar selector portname
-
- set recursive [string equal $selector "rdependentof"]
- add_multiple_ports reslist [get_dependent_ports $portname $recursive]
-
- set el 1
- }
-
- ^depof: -
- ^rdepof: {
- advance
-
- # Break up the token, because older Tcl switch doesn't support -matchvar
- regexp {^(\w+):(.*)} $token matchvar selector portname
-
- set recursive [string equal $selector "rdepof"]
- add_multiple_ports reslist [get_dep_ports $portname $recursive]
-
- set el 1
- }
-
- ^subportof: {
- advance
-
- # Break up the token, because older Tcl switch doesn't support -matchvar
- regexp {^(\w+):(.*)} $token matchvar selector portname
-
- add_multiple_ports reslist [get_subports $portname]
-
- set el 1
- }
-
- [][?*] { # Handle portname glob patterns
- advance; add_multiple_ports reslist [get_matching_ports $token no glob]
- set el 1
- }
-
- ^\\w+:.+ { # Handle a url by trying to open it as a port and mapping the name
- advance
- set name [url_to_portname $token]
- if {$name ne ""} {
- parsePortSpec version requested_variants options
- add_to_portlist reslist [list url $token \
- name $name \
- version $version \
- requested_variants [array get requested_variants] \
- variants [array get requested_variants] \
- options [array get options]]
- set el 1
- } else {
- ui_error "Can't open URL '$token' as a port"
- set el 0
- }
- }
-
- default { # Treat anything else as a portspec (portname, version, variants, options
- # or some combination thereof).
- parseFullPortSpec url name version requested_variants options
- add_to_portlist reslist [list url $url \
- name $name \
- version $version \
- requested_variants [array get requested_variants] \
- variants [array get requested_variants] \
- options [array get options]]
- set el 1
- }
- }
-
- return $el
-}
-
-
-proc add_multiple_ports { resname ports {remainder ""} } {
- upvar $resname reslist
-
- set version ""
- array unset variants
- array unset options
- parsePortSpec version variants options $remainder
-
- array unset overrides
- if {$version ne ""} { set overrides(version) $version }
- if {[array size variants]} {
- # we always record the requested variants separately,
- # but requested ones always override existing ones
- set overrides(requested_variants) [array get variants]
- set overrides(variants) [array get variants]
- }
- if {[array size options]} { set overrides(options) [array get options] }
-
- add_ports_to_portlist reslist $ports [array get overrides]
-}
-
-
-proc unique_entries { entries } {
- # Form the list of all the unique elements in the list a,
- # considering only the port fullname, and taking the first
- # found element first
- set result {}
- array unset unique
- foreach item $entries {
- array set port $item
- if {[info exists unique($port(fullname))]} continue
- set unique($port(fullname)) 1
- lappend result $item
- }
- return $result
-}
-
-
-proc opUnion { a b } {
- # Return the unique elements in the combined two lists
- return [unique_entries [concat $a $b]]
-}
-
-
-proc opIntersection { a b } {
- set result {}
-
- # Rules we follow in performing the intersection of two port lists:
- #
- # a/, a/ ==> a/
- # a/, b/ ==>
- # a/, a/1.0 ==> a/1.0
- # a/1.0, a/ ==> a/1.0
- # a/1.0, a/2.0 ==>
- #
- # If there's an exact match, we take it.
- # If there's a match between simple and discriminated, we take the later.
-
- # First create a list of the fully discriminated names in b
- array unset bfull
- set i 0
- foreach bitem [unique_entries $b] {
- array set port $bitem
- set bfull($port(fullname)) $i
- incr i
- }
-
- # Walk through each item in a, matching against b
- foreach aitem [unique_entries $a] {
- array set port $aitem
-
- # Quote the fullname and portname to avoid special characters messing up the regexp
- set safefullname [regex_pat_sanitize $port(fullname)]
-
- set simpleform [expr { "$port(name)/" == $port(fullname) }]
- if {$simpleform} {
- set pat "^${safefullname}"
- } else {
- set safename [regex_pat_sanitize $port(name)]
- set pat "^${safefullname}$|^${safename}/$"
- }
-
- set matches [array names bfull -regexp $pat]
- foreach match $matches {
- if {$simpleform} {
- set i $bfull($match)
- lappend result [lindex $b $i]
- } else {
- lappend result $aitem
- }
- }
- }
-
- return $result
-}
-
-
-proc opComplement { a b } {
- set result {}
-
- # Return all elements of a not matching elements in b
-
- # First create a list of the fully discriminated names in b
- array unset bfull
- set i 0
- foreach bitem $b {
- array set port $bitem
- set bfull($port(fullname)) $i
- incr i
- }
-
- # Walk through each item in a, taking all those items that don't match b
- foreach aitem $a {
- array set port $aitem
-
- # Quote the fullname and portname to avoid special characters messing up the regexp
- set safefullname [regex_pat_sanitize $port(fullname)]
-
- set simpleform [expr { "$port(name)/" == $port(fullname) }]
- if {$simpleform} {
- set pat "^${safefullname}"
- } else {
- set safename [regex_pat_sanitize $port(name)]
- set pat "^${safefullname}$|^${safename}/$"
- }
-
- set matches [array names bfull -regexp $pat]
-
- # We copy this element to result only if it didn't match against b
- if {![llength $matches]} {
- lappend result $aitem
- }
- }
-
- return $result
-}
-
-
-proc parseFullPortSpec { urlname namename vername varname optname } {
- upvar $urlname porturl
- upvar $namename portname
- upvar $vername portversion
- upvar $varname portvariants
- upvar $optname portoptions
-
- set portname ""
- set portversion ""
- array unset portvariants
- array unset portoptions
-
- if { [moreargs] } {
- # Look first for a potential portname
- #
- # We need to allow a wide variety of tokens here, because of actions like "provides"
- # so we take a rather lenient view of what a "portname" is. We allow
- # anything that doesn't look like either a version, a variant, or an option
- set token [lookahead]
-
- set remainder ""
- if {|[[:alpha:]_]+[\w\.]*=)} $token match]} {
- advance
- regexp {^([^@]+)(@.*)?} $token match portname remainder
-
- # If the portname contains a /, then try to use it as a URL
- if {[string match "*/*" $portname]} {
- set url "file://$portname"
- set name [url_to_portname $url 1]
- if { $name ne "" } {
- # We mapped the url to valid port
- set porturl $url
- set portname $name
- # Continue to parse rest of portspec....
- } else {
- # We didn't map the url to a port; treat it
- # as a raw string for something like port contents
- # or cd
- set porturl ""
- # Since this isn't a port, we don't try to parse
- # any remaining portspec....
- return
- }
- }
- }
-
- # Now parse the rest of the spec
- parsePortSpec portversion portvariants portoptions $remainder
- }
-}
-
-# check if the install prefix is writable
-# should be called by actions that will modify it
-proc prefix_unwritable {} {
- global macports::portdbpath
- if {[file writable $portdbpath]} {
- return 0
- } else {
- ui_error "Insufficient privileges to write to MacPorts install prefix."
- return 1
- }
-}
-
-
-proc parsePortSpec { vername varname optname {remainder ""} } {
- upvar $vername portversion
- upvar $varname portvariants
- upvar $optname portoptions
-
- global global_options
-
- set portversion ""
- array unset portoptions
- array set portoptions [array get global_options]
- array unset portvariants
-
- # Parse port version/variants/options
- set opt $remainder
- set adv 0
- set consumed 0
- for {set firstTime 1} {$opt ne "" || [moreargs]} {set firstTime 0} {
-
- # Refresh opt as needed
- if {$opt eq ""} {
- if {$adv} advance
- set opt [lookahead]
- set adv 1
- set consumed 0
- }
-
- # Version must be first, if it's there at all
- if {$firstTime && [string match {@*} $opt]} {
- # Parse the version
-
- # Strip the @
- set opt [string range $opt 1 end]
-
- # Handle the version
- set sepPos [string first "/" $opt]
- if {$sepPos >= 0} {
- # Version terminated by "/" to disambiguate -variant from part of version
- set portversion [string range $opt 0 [expr {$sepPos - 1}]]
- set opt [string range $opt [expr {$sepPos + 1}] end]
- } else {
- # Version terminated by "+", or else is complete
- set sepPos [string first "+" $opt]
- if {$sepPos >= 0} {
- # Version terminated by "+"
- set portversion [string range $opt 0 [expr {$sepPos - 1}]]
- set opt [string range $opt $sepPos end]
- } else {
- # Unterminated version
- set portversion $opt
- set opt ""
- }
- }
- set consumed 1
- } else {
- # Parse all other options
-
- # Look first for a variable setting: VARNAME=VALUE
- if {[regexp {^([[:alpha:]_]+[\w\.]*)=(.*)} $opt match key val] == 1} {
- # It's a variable setting
- set portoptions($key) "\"$val\""
- set opt ""
- set consumed 1
- } elseif {[regexp {^([-+])([[:alpha:]_]+[\w\.]*)} $opt match sign variant] == 1} {
- # It's a variant
- set portvariants($variant) $sign
- set opt [string range $opt [expr {[string length $variant] + 1}] end]
- set consumed 1
- } else {
- # Not an option we recognize, so break from port option processing
- if { $consumed && $adv } advance
- break
- }
- }
- }
-}
-
-
-##########################################
-# Action Handlers
-##########################################
-
-proc action_get_usage { action } {
- global action_array cmd_opts_array
-
- if {[info exists action_array($action)]} {
- set cmds ""
- if {[info exists cmd_opts_array($action)]} {
- foreach opt $cmd_opts_array($action) {
- if {[llength $opt] == 1} {
- set name $opt
- set optc 0
- } else {
- set name [lindex $opt 0]
- set optc [lindex $opt 1]
- }
-
- append cmds " --$name"
-
- for {set i 1} {$i <= $optc} {incr i} {
- append cmds " <arg$i>"
- }
- }
- }
- set args ""
- set needed [action_needs_portlist $action]
- if {[ACTION_ARGS_STRINGS] == $needed} {
- set args " <arguments>"
- } elseif {[ACTION_ARGS_STRINGS] == $needed} {
- set args " <portlist>"
- }
-
- set ret "Usage: "
- set len [string length $action]
- append ret [wrap "$action$cmds$args" 0 [string repeat " " [expr {8 + $len}]] 0]
- append ret "\n"
-
- return $ret
- }
-
- return -1
-}
-
-proc action_usage { action portlist opts } {
- if {[llength $portlist] == 0} {
- print_usage
- return 0
- }
-
- foreach topic $portlist {
- set usage [action_get_usage $topic]
- if {$usage != -1} {
- puts -nonewline stderr $usage
- } else {
- ui_error "No usage for topic $topic"
- return 1
- }
- }
- return 0
-}
-
-
-proc action_help { action portlist opts } {
- set helpfile "$macports::prefix/var/macports/port-help.tcl"
-
- if {[llength $portlist] == 0} {
- print_help
- return 0
- }
-
- if {[file exists $helpfile]} {
- if {[catch {source $helpfile} err]} {
- puts stderr "Error reading helpfile $helpfile: $err"
- return 1
- }
- } else {
- puts stderr "Unable to open help file $helpfile"
- return 1
- }
-
- foreach topic $portlist {
- if {![info exists porthelp($topic)]} {
- puts stderr "No help for topic $topic"
- return 1
- }
-
- set usage [action_get_usage $topic]
- if {$usage != -1} {
- puts -nonewline stderr $usage
- } else {
- ui_error "No usage for topic $topic"
- return 1
- }
-
- puts stderr $porthelp($topic)
- }
-
- return 0
-}
-
-
-proc action_log { action portlist opts } {
- global global_options
- if {[require_portlist portlist]} {
- return 1
- }
- foreachport $portlist {
- # If we have a url, use that, since it's most specific
- # otherwise try to map the portname to a url
- if {$porturl eq ""} {
- # Verify the portname, getting portinfo to map to a porturl
- if {[catch {mportlookup $portname} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Port $portname not found" 1 status
- }
- array unset portinfo
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
- set portdir $portinfo(portdir)
- set portname $portinfo(name)
- } elseif {$porturl ne "file://."} {
- # Extract the portdir from porturl and use it to search PortIndex.
- # Only the last two elements of the path (porturl) make up the
- # portdir.
- set portdir [file split [macports::getportdir $porturl]]
- set lsize [llength $portdir]
- set portdir \
- [file join [lindex $portdir [expr {$lsize - 2}]] \
- [lindex $portdir [expr {$lsize - 1}]]]
- if {[catch {mportsearch $portdir no exact portdir} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Portdir $portdir not found" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Portdir $portdir not found" 1 status
- }
- array unset portinfo
- set matchindex [lsearch -exact -nocase $result $portname]
- if {$matchindex != -1} {
- array set portinfo [lindex $result [incr matchindex]]
- } else {
- ui_warn "Portdir $portdir doesn't seem to belong to portname $portname"
- array set portinfo [lindex $result 1]
- }
- set portname $portinfo(name)
- }
- set portpath [macports::getportdir $porturl]
- set logfile [file join [macports::getportlogpath $portpath $portname] "main.log"]
- if {[file exists $logfile]} {
- if {[catch {set fp [open $logfile r]} result]} {
- break_softcontinue "Could not open file $logfile: $result" 1 status
- }
- set data [read $fp]
- set data [split $data "\n"]
-
- if {[info exists global_options(ports_log_phase)]} {
- set phase $global_options(ports_log_phase);
- } else {
- set phase "\[a-z\]*"
- }
-
- if {[info exists global_options(ports_log_level)]} {
- set index [lsearch -exact ${macports::ui_priorities} $global_options(ports_log_level)]
- if {$index == -1} {
- set prefix ""
- } else {
- set prefix [join [lrange ${macports::ui_priorities} 0 $index] "|"]
- }
- } else {
- set prefix "\[a-z\]*"
- }
- foreach line $data {
- set exp "^:($prefix|any):($phase|any) (.*)$"
- if {[regexp $exp $line -> lpriority lphase lmsg] == 1} {
- puts "[macports::ui_prefix_default $lpriority]$lmsg"
- }
- }
-
- close $fp
- } else {
- break_softcontinue "Log file for port $portname not found" 1 status
- }
- }
- return 0
-}
-
-
-proc action_info { action portlist opts } {
- global global_variations
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
-
- set separator ""
- foreachport $portlist {
- set index_only 0
- if {[info exists options(ports_info_index)] && $options(ports_info_index)} {
- set index_only 1
- }
- puts -nonewline $separator
- array unset portinfo
- # If we have a url, use that, since it's most specific
- # otherwise try to map the portname to a url
- if {$porturl eq "" || $index_only} {
- # Verify the portname, getting portinfo to map to a porturl
- if {[catch {mportlookup $portname} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Port $portname not found" 1 status
- }
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
- set portdir $portinfo(portdir)
- }
-
- if {!$index_only} {
- # Add any global_variations to the variations
- # specified for the port (so we get e.g. dependencies right)
- array unset merged_variations
- array set merged_variations [array get variations]
- foreach { variation value } [array get global_variations] {
- if { ![info exists merged_variations($variation)] } {
- set merged_variations($variation) $value
- }
- }
- if {![info exists options(subport)]} {
- if {[info exists portinfo(name)]} {
- set options(subport) $portinfo(name)
- } else {
- set options(subport) $portname
- }
- }
-
- if {[catch {set mport [mportopen $porturl [array get options] [array get merged_variations]]} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Unable to open port: $result" 1 status
- }
- unset options(subport)
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
- if {[info exists portdir]} {
- set portinfo(portdir) $portdir
- }
- } elseif {![info exists portinfo]} {
- ui_warn "no PortIndex entry found for $portname"
- continue
- }
- array unset options ports_info_index
-
- # Understand which info items are actually lists
- # (this could be overloaded to provide a generic formatting code to
- # allow us to, say, split off the prefix on libs)
- array set list_map "
- categories 1
- depends_fetch 1
- depends_extract 1
- depends_build 1
- depends_lib 1
- depends_run 1
- maintainers 1
- platforms 1
- variants 1
- conflicts 1
- subports 1
- "
-
- # Label map for pretty printing
- array set pretty_label {
- heading ""
- variants Variants
- depends_fetch "Fetch Dependencies"
- depends_extract "Extract Dependencies"
- depends_build "Build Dependencies"
- depends_run "Runtime Dependencies"
- depends_lib "Library Dependencies"
- description "Brief Description"
- long_description "Description"
- fullname "Full Name: "
- homepage Homepage
- platforms Platforms
- maintainers Maintainers
- license License
- conflicts "Conflicts with"
- replaced_by "Replaced by"
- subports "Sub-ports"
- }
-
- # Wrap-length map for pretty printing
- array set pretty_wrap {
- heading 0
- replaced_by 22
- variants 22
- depends_fetch 22
- depends_extract 22
- depends_build 22
- depends_run 22
- depends_lib 22
- description 22
- long_description 22
- homepage 22
- platforms 22
- license 22
- conflicts 22
- maintainers 22
- subports 22
- }
-
- # Interpret a convenient field abbreviation
- if {[info exists options(ports_info_depends)] && $options(ports_info_depends) eq "yes"} {
- array unset options ports_info_depends
- set options(ports_info_depends_fetch) yes
- set options(ports_info_depends_extract) yes
- set options(ports_info_depends_build) yes
- set options(ports_info_depends_lib) yes
- set options(ports_info_depends_run) yes
- }
-
- # Set up our field separators
- set show_label 1
- set field_sep "\n"
- set subfield_sep ", "
- set pretty_print 0
-
- # For human-readable summary, which is the default with no options
- if {[llength [array get options ports_info_*]] == 0} {
- set pretty_print 1
- } elseif {[info exists options(ports_info_pretty)]} {
- set pretty_print 1
- array unset options ports_info_pretty
- }
-
- # Tune for sort(1)
- if {[info exists options(ports_info_line)]} {
- array unset options ports_info_line
- set noseparator 1
- set show_label 0
- set field_sep "\t"
- set subfield_sep ","
- }
-
- # Figure out whether to show field name
- set quiet [macports::ui_isset ports_quiet]
- if {$quiet} {
- set show_label 0
- }
- # In pretty-print mode we also suppress messages, even though we show
- # most of the labels:
- if {$pretty_print} {
- set quiet 1
- }
-
- # Spin through action options, emitting information for any found
- set fields {}
- set opts_todo [array names options ports_info_*]
- set fields_tried {}
- if {![llength $opts_todo]} {
- set opts_todo {ports_info_heading
- ports_info_replaced_by
- ports_info_subports
- ports_info_variants
- ports_info_skip_line
- ports_info_long_description ports_info_homepage
- ports_info_skip_line ports_info_depends_fetch
- ports_info_depends_extract ports_info_depends_build
- ports_info_depends_lib ports_info_depends_run
- ports_info_conflicts
- ports_info_platforms ports_info_license
- ports_info_maintainers
- }
- }
- foreach { option } $opts_todo {
- set opt [string range $option 11 end]
- # Artificial field name for formatting
- if {$pretty_print && $opt eq "skip_line"} {
- lappend fields ""
- continue
- }
- # Artificial field names to reproduce prettyprinted summary
- if {$opt eq "heading"} {
- set inf "$portinfo(name) @$portinfo(version)"
- set ropt "heading"
- if {[info exists portinfo(revision)] && $portinfo(revision) > 0} {
- append inf "_$portinfo(revision)"
- }
- if {[info exists portinfo(categories)]} {
- append inf " ([join $portinfo(categories) ", "])"
- }
- } elseif {$opt eq "fullname"} {
- set inf "$portinfo(name) @"
- append inf [composite_version $portinfo(version) $portinfo(active_variants)]
- set ropt "fullname"
- } else {
- # Map from friendly name
- set ropt [map_friendly_field_names $opt]
-
- # If there's no such info, move on
- if {![info exists portinfo($ropt)]} {
- set inf ""
- } else {
- set inf [join $portinfo($ropt)]
- }
- }
-
- # Calculate field label
- set label ""
- if {$pretty_print} {
- if {[info exists pretty_label($ropt)]} {
- set label $pretty_label($ropt)
- } else {
- set label $opt
- }
- } elseif {$show_label} {
- set label "$opt: "
- }
-
- # Format the data
- if { $ropt eq "maintainers" } {
- set inf [unobscure_maintainers $inf]
- }
- # ... special formatting for certain fields when prettyprinting
- if {$pretty_print} {
- if {$ropt eq "variants"} {
- # Use the new format for variants iff it exists in
- # PortInfo. This key currently does not exist outside of
- # trunk (1.8.0).
- array unset vinfo
- if {[info exists portinfo(vinfo)]} {
- array set vinfo $portinfo(vinfo)
- }
-
- set pi_vars $inf
- set inf {}
- foreach v [lsort $pi_vars] {
- set varmodifier ""
- if {[info exists variations($v)]} {
- # selected by command line, prefixed with +/-
- set varmodifier $variations($v)
- } elseif {[info exists global_variations($v)]} {
- # selected by variants.conf, prefixed with (+)/(-)
- set varmodifier "($global_variations($v))"
- # Retrieve additional information from the new key.
- } elseif {[info exists vinfo]} {
- array unset variant
- array set variant $vinfo($v)
- if {[info exists variant(is_default)]} {
- set varmodifier "\[$variant(is_default)]"
- }
- }
- lappend inf "$varmodifier$v"
- }
- } elseif {[string match "depend*" $ropt]
- && ![macports::ui_isset ports_verbose]} {
- set pi_deps $inf
- set inf {}
- foreach d $pi_deps {
- lappend inf [lindex [split $d :] end]
- }
- }
- }
- #End of special pretty-print formatting for certain fields
- if {[info exists list_map($ropt)]} {
- set field [join $inf $subfield_sep]
- } else {
- set field $inf
- }
-
- # Assemble the entry
- if {$pretty_print} {
- # The two special fields are considered headings and are
- # emitted immediately, rather than waiting. Also they are not
- # recorded on the list of fields tried
- if {$ropt eq "heading" || $ropt eq "fullname"} {
- puts "$label$field"
- continue
- }
- }
- lappend fields_tried $label
- if {$pretty_print} {
- if {$field eq ""} {
- continue
- }
- if {$label eq ""} {
- set wrap_len 0
- if {[info exists pretty_wrap($ropt)]} {
- set wrap_len $pretty_wrap($ropt)
- }
- lappend fields [wrap $field 0 [string repeat " " $wrap_len]]
- } else {
- set wrap_len [string length $label]
- if {[info exists pretty_wrap($ropt)]} {
- set wrap_len $pretty_wrap($ropt)
- }
- lappend fields [wraplabel $label $field 0 [string repeat " " $wrap_len]]
- }
-
- } else { # Not pretty print
- lappend fields "$label$field"
- }
- }
-
- # Now output all that information:
- if {[llength $fields]} {
- puts [join $fields $field_sep]
- } else {
- if {$pretty_print && [llength $fields_tried]} {
- puts -nonewline "$portinfo(name) has no "
- puts [join $fields_tried ", "]
- }
- }
- if {![info exists noseparator]} {
- set separator "--\n"
- }
- }
-
- return $status
-}
-
-
-proc action_location { action portlist opts } {
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
- foreachport $portlist {
- if { [catch {set ilist [registry_installed $portname [composite_version $portversion [array get variations]]]} result] } {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port location failed: $result" 1 status
- } else {
- # set portname again since the one we were passed may not have had the correct case
- set portname [lindex $ilist 0]
- set version [lindex $ilist 1]
- set revision [lindex $ilist 2]
- set variants [lindex $ilist 3]
- set epoch [lindex $ilist 5]
- }
-
- set ref [registry::open_entry $portname $version $revision $variants $epoch]
- set imagedir [registry::property_retrieve $ref location]
- ui_notice "Port $portname ${version}_${revision}${variants} is installed as an image in:"
- puts $imagedir
- }
-
- return $status
-}
-
-
-proc action_notes { action portlist opts } {
- if {[require_portlist portlist]} {
- return 1
- }
-
- set status 0
- foreachport $portlist {
- array unset portinfo
- if {$porturl eq ""} {
- # Look up the port.
- if {[catch {mportlookup $portname} result]} {
- ui_debug $::errorInfo
- break_softcontinue "The lookup of '$portname' failed: $result" \
- 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "The port '$portname' was not found" 1 status
- }
-
- # Retrieve the port's URL.
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
- }
-
- # Add any global_variations to the variations
- # specified for the port
- array unset merged_variations
- array set merged_variations [array get variations]
- foreach { variation value } [array get global_variations] {
- if { ![info exists merged_variations($variation)] } {
- set merged_variations($variation) $value
- }
- }
- if {![info exists options(subport)]} {
- if {[info exists portinfo(name)]} {
- set options(subport) $portinfo(name)
- } else {
- set options(subport) $portname
- }
- }
-
- # Open the Portfile associated with this port.
- if {[catch {set mport [mportopen $porturl [array get options] \
- [array get merged_variations]]} \
- result]} {
- ui_debug $::errorInfo
- break_softcontinue [concat "The URL '$porturl' could not be" \
- "opened: $result"] 1 status
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
-
- # Return the notes associated with this Portfile.
- if {[info exists portinfo(notes)]} {
- set portnotes $portinfo(notes)
- } else {
- set portnotes {}
- }
-
- # Retrieve the port's name once more to ensure it has the proper case.
- set portname $portinfo(name)
-
- # Display the notes.
- if {$portnotes ne {}} {
- ui_notice "$portname has the following notes:"
- foreach note $portnotes {
- puts [wrap $note 0 " " 1]
- }
- } else {
- puts "$portname has no notes."
- }
- }
- return $status
-}
-
-
-proc action_provides { action portlist opts } {
- # In this case, portname is going to be used for the filename... since
- # that is the first argument we expect... perhaps there is a better way
- # to do this?
- if { ![llength $portlist] } {
- ui_error "Please specify a filename to check which port provides that file."
- return 1
- }
- foreach filename $portlist {
- set file [file normalize $filename]
- if {[file exists $file] || ![catch {file type $file}]} {
- if {![file isdirectory $file] || [file type $file] eq "link"} {
- set port [registry::file_registered $file]
- if { $port != 0 } {
- puts "$file is provided by: $port"
- } else {
- puts "$file is not provided by a MacPorts port."
- }
- } else {
- puts "$file is a directory."
- }
- } else {
- puts "$file does not exist."
- }
- }
- registry::close_file_map
-
- return 0
-}
-
-
-proc action_activate { action portlist opts } {
- set status 0
- if {[require_portlist portlist] || [prefix_unwritable]} {
- return 1
- }
- foreachport $portlist {
- set composite_version [composite_version $portversion [array get variations]]
- if {![info exists options(ports_activate_no-exec)]
- && ![catch {set ilist [registry::installed $portname $composite_version]}]
- && [llength $ilist] == 1} {
-
- set i [lindex $ilist 0]
- set regref [registry::entry open $portname [lindex $i 1] [lindex $i 2] [lindex $i 3] [lindex $i 5]]
- if {[$regref installtype] eq "image" && [registry::run_target $regref activate [array get options]]} {
- continue
- }
- }
- if {![macports::global_option_isset ports_dryrun]} {
- if { [catch {portimage::activate_composite $portname $composite_version [array get options]} result] } {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port activate failed: $result" 1 status
- }
- } else {
- ui_msg "Skipping activate $portname (dry run)"
- }
- }
-
- return $status
-}
-
-
-proc action_deactivate { action portlist opts } {
- set status 0
- if {[require_portlist portlist] || [prefix_unwritable]} {
- return 1
- }
- set portlist [portlist_sortdependents $portlist]
- foreachport $portlist {
- set composite_version [composite_version $portversion [array get variations]]
- if {![info exists options(ports_deactivate_no-exec)]
- && ![catch {set ilist [registry::active $portname]}]} {
-
- set i [lindex $ilist 0]
- set iversion [lindex $i 1]
- set irevision [lindex $i 2]
- set ivariants [lindex $i 3]
- if {$composite_version eq "" || $composite_version == "${iversion}_${irevision}${ivariants}"} {
- set regref [registry::entry open $portname $iversion $irevision $ivariants [lindex $i 5]]
- if {[$regref installtype] eq "image" && [registry::run_target $regref deactivate [array get options]]} {
- continue
- }
- }
- }
- if {![macports::global_option_isset ports_dryrun]} {
- if { [catch {portimage::deactivate_composite $portname $composite_version [array get options]} result] } {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port deactivate failed: $result" 1 status
- }
- } else {
- ui_msg "Skipping deactivate $portname (dry run)"
- }
- }
-
- return $status
-}
-
-
-proc action_select { action portlist opts } {
- ui_debug "action_select \[$portlist] \[$opts]..."
-
- array set opts_array $opts
- set commands [array names opts_array ports_select_*]
- array unset opts_array
-
- # Error out if no group is specified or command is not --summary.
- if {[llength $portlist] < 1 && [string map {ports_select_ ""} [lindex $commands 0]] != "summary"} {
- ui_error "port select \[--list|--set|--show|--summary] \<group> \[<version>]"
- return 1
- }
-
- set group [lindex $portlist 0]
-
- # If no command (--set, --show, --list, --summary) is specified *but*
- # more than one argument is specified, default to the set command.
- if {[llength $commands] < 1 && [llength $portlist] > 1} {
- set command set
- ui_debug [concat "Although no command was specified, more than " \
- "one argument was specified. Defaulting to the " \
- "'set' command..."]
- # If no command (--set, --show, --list) is specified *and* less than two
- # argument are specified, default to the list command.
- } elseif {[llength $commands] < 1} {
- set command list
- ui_debug [concat "No command was specified. Defaulting to the " \
- "'list' command..."]
- # Only allow one command to be specified at a time.
- } elseif {[llength $commands] > 1} {
- ui_error [concat "Multiple commands were specified. Only one " \
- "command may be specified at a time."]
- return 1
- } else {
- set command [string map {ports_select_ ""} [lindex $commands 0]]
- ui_debug "The '$command' command was specified."
- }
-
- switch -- $command {
- list {
- if {[llength $portlist] > 1} {
- ui_warn [concat "The 'list' command does not expect any " \
- "arguments. Extra arguments will be ignored."]
- }
-
- if {[catch {mportselect show $group} selected_version]} {
- global errorInfo
- ui_debug $errorInfo
- ui_warn "Unable to get active selected version: $selected_version"
- }
-
- # On error mportselect returns with the code 'error'.
- if {[catch {mportselect $command $group} versions]} {
- ui_error "The 'list' command failed: $versions"
- return 1
- }
-
- ui_notice "Available versions for $group:"
- foreach v $versions {
- ui_notice -nonewline "\t"
- if {$selected_version == $v} {
- ui_msg "$v (active)"
- } else {
- ui_msg "$v"
- }
- }
- return 0
- }
- set {
- if {[llength $portlist] < 2} {
- ui_error [concat "The 'set' command expects two " \
- "arguments: <group>, <version>"]
- return 1
- } elseif {[llength $portlist] > 2} {
- ui_warn [concat "The 'set' command only expects two " \
- "arguments. Extra arguments will be " \
- "ignored."]
- }
- set version [lindex $portlist 1]
-
- ui_msg -nonewline "Selecting '$version' for '$group' "
- if {[catch {mportselect $command $group $version} result]} {
- ui_msg "failed: $result"
- return 1
- }
- ui_msg "succeeded. '$version' is now active."
- return 0
- }
- show {
- if {[llength $portlist] > 1} {
- ui_warn [concat "The 'show' command does not expect any " \
- "arguments. Extra arguments will be ignored."]
- }
-
- if {[catch {mportselect $command $group} selected_version]} {
- ui_error "The 'show' command failed: $selected_version"
- return 1
- }
- puts [concat "The currently selected version for '$group' is " \
- "'$selected_version'."]
- return 0
- }
- summary {
- if {[llength $portlist] > 0} {
- ui_warn [concat "The 'summary' command does not expect any " \
- "arguments. Extra arguments will be ignored."]
- }
-
- if {[catch {mportselect $command} portgroups]} {
- ui_error "The 'summary' command failed: $portgroups"
- return 1
- }
-
- set w1 4
- set w2 8
- set formatStr "%-*s %-*s %s"
-
- set groups [list]
- foreach pg $portgroups {
- array set groupdesc {}
- set groupdesc(name) [string trim $pg]
-
- if {[catch {mportselect list $pg} versions]} {
- ui_warn "The list of options for the select group $pg could not be obtained: $versions"
- continue
- }
- # remove "none", sort the list, append none at the end
- set noneidx [lsearch -exact $versions "none"]
- set versions [lsort [lreplace $versions $noneidx $noneidx]]
- lappend versions "none"
- set groupdesc(versions) $versions
-
- if {[catch {mportselect show $pg} selected_version]} {
- ui_warn "The currently selected option for the select group $pg could not be obtained: $selected_version"
- continue
- }
- set groupdesc(selected) $selected_version
-
- set w1 [expr {max($w1, [string length $pg])}]
- set w2 [expr {max($w2, [string length $selected_version])}]
-
- lappend groups [array get groupdesc]
- array unset groupdesc
- }
- puts [format $formatStr $w1 "Name" $w2 "Selected" "Options"]
- puts [format $formatStr $w1 "====" $w2 "========" "======="]
- foreach groupdesc $groups {
- array set groupd $groupdesc
- puts [format $formatStr $w1 $groupd(name) $w2 $groupd(selected) [join $groupd(versions) " "]]
- array unset groupd
- }
- return 0
- }
- default {
- ui_error "An unknown command '$command' was specified."
- return 1
- }
- }
-}
-
-
-proc action_selfupdate { action portlist opts } {
- global global_options
- if { [catch {macports::selfupdate [array get global_options] base_updated} result ] } {
- global errorInfo
- ui_debug "$errorInfo"
- ui_error "$result"
- if {![macports::ui_isset ports_verbose]} {
- ui_msg "Please run `port -v selfupdate' for details."
- } else {
- # Let's only print the ticket URL if the user has followed the
- # advice we printed earlier.
- print_tickets_url
- }
- fatal "port selfupdate failed: $result"
- }
-
- if {$base_updated} {
- # exit immediately if in batch/interactive mode
- return -999
- } else {
- return 0
- }
-}
-
-
-proc action_setrequested { action portlist opts } {
- set status 0
- if {[require_portlist portlist] || [prefix_unwritable]} {
- return 1
- }
- # set or unset?
- set val [string equal $action "setrequested"]
- foreachport $portlist {
- set composite_version [composite_version $portversion [array get variations]]
- if {![catch {set ilist [registry::installed $portname $composite_version]} result]} {
- ui_info "Setting requested flag for $portname to $val"
- foreach i $ilist {
- set regref [registry::open_entry $portname [lindex $i 1] [lindex $i 2] [lindex $i 3] [lindex $i 5]]
- registry::property_store $regref requested $val
- }
- } else {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "$result" 1 status
- }
- }
-
- return $status
-}
-
-
-proc action_upgrade { action portlist opts } {
- if {[require_portlist portlist "yes"] || ([prefix_unwritable] && ![macports::global_option_isset ports_dryrun])} {
- return 1
- }
-
- # shared depscache for all ports in the list
- array set depscache {}
- set status 0
- foreachport $portlist {
- if {![info exists depscache(port:$portname)]} {
- set status [macports::upgrade $portname "port:$portname" [array get requested_variations] [array get options] depscache]
- # status 2 means the port was not found in the index,
- # status 3 means the port is not installed
- if {$status != 0 && $status != 2 && $status != 3 && ![macports::ui_isset ports_processall]} {
- break
- }
- }
- }
-
- if {$status != 0 && $status != 2 && $status != 3} {
- print_tickets_url
- } elseif {$status == 0} {
- array set options $opts
- if {![info exists options(ports_upgrade_no-rev-upgrade)] && ${macports::revupgrade_autorun} && ![macports::global_option_isset ports_dryrun]} {
- set status [action_revupgrade $action $portlist $opts]
- }
- }
-
- return $status
-}
-
-proc action_doctor { action portlist opts } {
- macports::doctor_main
- return 0
-}
-
-proc action_reclaim { action portlist opts } {
- macports::reclaim_main
- return 0
-}
-
-proc action_revupgrade { action portlist opts } {
- set status [macports::revupgrade $opts]
- if {$status != 0} {
- print_tickets_url
- }
- return $status
-}
-
-
-proc action_version { action portlist opts } {
- if {![macports::ui_isset ports_quiet]} {
- puts -nonewline "Version: "
- }
- puts [macports::version]
- return 0
-}
-
-
-proc action_platform { action portlist opts } {
- if {![macports::ui_isset ports_quiet]} {
- puts -nonewline "Platform: "
- }
- puts "${macports::os_platform} ${macports::os_major} ${macports::os_arch}"
- return 0
-}
-
-
-proc action_dependents { action portlist opts } {
- if {[require_portlist portlist]} {
- return 1
- }
- set ilist {}
-
- registry::open_dep_map
-
- set status 0
- foreachport $portlist {
- set composite_version [composite_version $portversion [array get variations]]
- if { [catch {set ilist [registry::installed $portname $composite_version]} result] } {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "$result" 1 status
- } else {
- # choose the active version if there is one
- set index 0
- foreach i $ilist {
- if {[lindex $i 4]} {
- set found 1
- break
- }
- incr index
- }
- if {![info exists found]} {
- set index 0
- }
- # set portname again since the one we were passed may not have had the correct case
- set portname [lindex $ilist $index 0]
- set iversion [lindex $ilist $index 1]
- set irevision [lindex $ilist $index 2]
- set ivariants [lindex $ilist $index 3]
- }
-
- set deplist [registry::list_dependents $portname $iversion $irevision $ivariants]
- if { [llength $deplist] > 0 } {
- if {$action eq "rdependents"} {
- set toplist $deplist
- while 1 {
- set newlist {}
- foreach dep $deplist {
- set depname [lindex $dep 2]
- if {![info exists seen($depname)]} {
- set seen($depname) 1
- set rdeplist [registry::list_dependents $depname]
- foreach rdep $rdeplist {
- lappend newlist $rdep
- }
- set dependentsof($depname) $rdeplist
- }
- }
- if {[llength $newlist] > 0} {
- set deplist $newlist
- } else {
- break
- }
- }
- set portstack [list $toplist]
- set pos_stack [list 0]
- array unset seen
- ui_notice "The following ports are dependent on ${portname}:"
- while 1 {
- set cur_portlist [lindex $portstack end]
- set cur_pos [lindex $pos_stack end]
- if {$cur_pos >= [llength $cur_portlist]} {
- set portstack [lreplace $portstack end end]
- set pos_stack [lreplace $pos_stack end end]
- if {[llength $portstack] <= 0} {
- break
- } else {
- continue
- }
- }
- set cur_port [lindex $cur_portlist $cur_pos]
- set cur_portname [lindex $cur_port 2]
- set spaces [string repeat " " [expr {[llength $pos_stack] * 2}]]
- if {![info exists seen($cur_portname)] || ([info exists options(ports_rdependents_full)] && [string is true -strict $options(ports_rdependents_full)])} {
- puts "${spaces}${cur_portname}"
- set seen($cur_portname) 1
- incr cur_pos
- set pos_stack [lreplace $pos_stack end end $cur_pos]
- if {[info exists dependentsof($cur_portname)]} {
- lappend portstack $dependentsof($cur_portname)
- lappend pos_stack 0
- }
- continue
- }
- incr cur_pos
- set pos_stack [lreplace $pos_stack end end $cur_pos]
- }
- } else {
- foreach dep $deplist {
- set depport [lindex $dep 2]
- if {[macports::ui_isset ports_quiet]} {
- ui_msg "$depport"
- } elseif {![macports::ui_isset ports_verbose]} {
- ui_msg "$depport depends on $portname"
- } else {
- ui_msg "$depport depends on $portname (by [lindex $dep 1]:)"
- }
- }
- }
- } else {
- ui_notice "$portname has no dependents."
- }
- }
- return $status
-}
-
-
-proc action_deps { action portlist opts } {
- global global_variations
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
- set separator ""
-
- foreachport $portlist {
- if {[info exists options(ports_${action}_no-build)] && [string is true -strict $options(ports_${action}_no-build)]} {
- set deptypes {depends_lib depends_run}
- } else {
- set deptypes {depends_fetch depends_extract depends_build depends_lib depends_run}
- }
-
- array unset portinfo
- # If we have a url, use that, since it's most specific
- # otherwise try to map the portname to a url
- if {$porturl eq ""} {
- # Verify the portname, getting portinfo to map to a porturl
- if {[catch {mportlookup $portname} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Port $portname not found" 1 status
- }
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
- } elseif {$porturl ne "file://."} {
- # Extract the portdir from porturl and use it to search PortIndex.
- # Only the last two elements of the path (porturl) make up the
- # portdir.
- set portdir [file split [macports::getportdir $porturl]]
- set lsize [llength $portdir]
- set portdir \
- [file join [lindex $portdir [expr {$lsize - 2}]] \
- [lindex $portdir [expr {$lsize - 1}]]]
- if {[catch {mportsearch $portdir no exact portdir} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Portdir $portdir not found" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Portdir $portdir not found" 1 status
- }
- set matchindex [lsearch -exact -nocase $result $portname]
- if {$matchindex != -1} {
- array set portinfo [lindex $result [incr matchindex]]
- } else {
- ui_warn "Portdir $portdir doesn't seem to belong to portname $portname"
- array set portinfo [lindex $result 1]
- }
- }
-
- if {!([info exists options(ports_${action}_index)] && $options(ports_${action}_index) eq "yes")} {
- # Add any global_variations to the variations
- # specified for the port, so we get dependencies right
- array unset merged_variations
- array set merged_variations [array get variations]
- foreach { variation value } [array get global_variations] {
- if { ![info exists merged_variations($variation)] } {
- set merged_variations($variation) $value
- }
- }
- if {![info exists options(subport)]} {
- if {[info exists portinfo(name)]} {
- set options(subport) $portinfo(name)
- } else {
- set options(subport) $portname
- }
- }
- if {[catch {set mport [mportopen $porturl [array get options] [array get merged_variations]]} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Unable to open port: $result" 1 status
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
- } elseif {![info exists portinfo]} {
- ui_warn "port ${action} --index does not work with the 'current' pseudo-port"
- continue
- }
- set portname $portinfo(name)
-
- set deplist {}
- set deps_output {}
- set ndeps 0
- array set labeldict {depends_fetch Fetch depends_extract Extract depends_build Build depends_lib Library depends_run Runtime}
- # get list of direct deps
- foreach type $deptypes {
- if {[info exists portinfo($type)]} {
- if {$action eq "rdeps" || [macports::ui_isset ports_verbose]} {
- foreach dep $portinfo($type) {
- lappend deplist $dep
- }
- } else {
- foreach dep $portinfo($type) {
- lappend deplist [lindex [split $dep :] end]
- }
- }
- if {$action eq "deps"} {
- set label "$labeldict($type) Dependencies"
- lappend deps_output [wraplabel $label [join $deplist ", "] 0 [string repeat " " 22]]
- incr ndeps [llength $deplist]
- set deplist {}
- }
- }
- }
-
- set version $portinfo(version)
- set revision $portinfo(revision)
- if {[info exists portinfo(canonical_active_variants)]} {
- set variants $portinfo(canonical_active_variants)
- } else {
- set variants {}
- }
-
- puts -nonewline $separator
- if {$action eq "deps"} {
- if {$ndeps == 0} {
- ui_notice "$portname @${version}_${revision}${variants} has no dependencies."
- } else {
- ui_notice "Full Name: $portname @${version}_${revision}${variants}"
- puts [join $deps_output "\n"]
- }
- set separator "--\n"
- continue
- }
-
- set toplist $deplist
- # gather all the deps
- while 1 {
- set newlist {}
- foreach dep $deplist {
- set depname [lindex [split $dep :] end]
- if {![info exists seen($depname)]} {
- set seen($depname) 1
-
- # look up the dep
- if {[catch {mportlookup $depname} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "lookup of portname $depname failed: $result" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Port $depname not found" 1 status
- }
- array unset portinfo
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
- set options(subport) $portinfo(name)
-
- # open the portfile if requested
- if {!([info exists options(ports_${action}_index)] && $options(ports_${action}_index) eq "yes")} {
- if {[catch {set mport [mportopen $porturl [array get options] [array get merged_variations]]} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Unable to open port: $result" 1 status
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
- }
-
- # get list of the dep's deps
- set rdeplist {}
- foreach type $deptypes {
- if {[info exists portinfo($type)]} {
- foreach rdep $portinfo($type) {
- lappend rdeplist $rdep
- lappend newlist $rdep
- }
- }
- }
- set depsof($depname) $rdeplist
- }
- }
- if {[llength $newlist] > 0} {
- set deplist $newlist
- } else {
- break
- }
- }
- set portstack [list $toplist]
- set pos_stack [list 0]
- array unset seen
- if {[llength $toplist] > 0} {
- ui_notice "The following ports are dependencies of $portname @${version}_${revision}${variants}:"
- } else {
- ui_notice "$portname @${version}_${revision}${variants} has no dependencies."
- }
- while 1 {
- set cur_portlist [lindex $portstack end]
- set cur_pos [lindex $pos_stack end]
- if {$cur_pos >= [llength $cur_portlist]} {
- set portstack [lreplace $portstack end end]
- set pos_stack [lreplace $pos_stack end end]
- if {[llength $portstack] <= 0} {
- break
- } else {
- continue
- }
- }
- set cur_port [lindex $cur_portlist $cur_pos]
- set cur_portname [lindex [split $cur_port :] end]
- set spaces [string repeat " " [expr {[llength $pos_stack] * 2}]]
- if {![info exists seen($cur_portname)] || ([info exists options(ports_${action}_full)] && [string is true -strict $options(ports_${action}_full)])} {
- if {[macports::ui_isset ports_verbose]} {
- puts "${spaces}${cur_port}"
- } else {
- puts "${spaces}${cur_portname}"
- }
- set seen($cur_portname) 1
- incr cur_pos
- set pos_stack [lreplace $pos_stack end end $cur_pos]
- if {[info exists depsof($cur_portname)]} {
- lappend portstack $depsof($cur_portname)
- lappend pos_stack 0
- }
- continue
- }
- incr cur_pos
- set pos_stack [lreplace $pos_stack end end $cur_pos]
- }
- set separator "--\n"
- }
- return $status
-}
-
-
-proc action_uninstall { action portlist opts } {
- set status 0
- if {[macports::global_option_isset port_uninstall_old]} {
- # if -u then uninstall all inactive ports
- # (union these to any other ports user has in the port list)
- set portlist [opUnion $portlist [get_inactive_ports]]
- } else {
- # Otherwise the user hopefully supplied a portlist, or we'll default to the existing directory
- if {[require_portlist portlist]} {
- return 1
- }
- }
- if {[prefix_unwritable]} {
- return 1
- }
-
- set portlist [portlist_sortdependents $portlist]
-
- foreachport $portlist {
- if {![registry::entry_exists_for_name $portname]} {
- # if the code path arrives here the port either isn't installed, or
- # it doesn't exist at all. We can't be sure, but we can check the
- # portindex whether a port by that name exists (in which case not
- # uninstalling it is probably no problem). If there is no port by
- # that name, alert the user in case of typos.
- ui_info "$portname is not installed"
- if {[catch {set res [mportlookup $portname]} result] || [llength $res] == 0} {
- ui_warn "no such port: $portname, skipping uninstall"
- }
- continue
- }
- set composite_version [composite_version $portversion [array get variations]]
- if {![info exists options(ports_uninstall_no-exec)]
- && ![catch {set ilist [registry::installed $portname $composite_version]}]
- && [llength $ilist] == 1} {
-
- set i [lindex $ilist 0]
- set iactive [lindex $i 4]
- set regref [registry::entry open $portname [lindex $i 1] [lindex $i 2] [lindex $i 3] [lindex $i 5]]
- if {[registry::run_target $regref uninstall [array get options]]} {
- continue
- }
- }
-
- if { [catch {registry_uninstall::uninstall_composite $portname $composite_version [array get options]} result] } {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port uninstall failed: $result" 1 status
- }
- }
-
- return $status
-}
-
-
-proc action_installed { action portlist opts } {
- global private_options
- set status 0
- set restrictedList 0
- set ilist {}
-
- if { [llength $portlist] || (![info exists private_options(ports_no_args)] || $private_options(ports_no_args) eq "no")} {
- set restrictedList 1
- foreachport $portlist {
- set composite_version [composite_version $portversion [array get variations]]
- if { [catch {set ilist [concat $ilist [registry::installed $portname $composite_version]]} result] } {
- if {![string match "* not registered as installed." $result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port installed failed: $result" 1 status
- }
- }
- }
- } else {
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- ui_error "port installed failed: $result"
- set status 1
- }
- }
- }
- if { [llength $ilist] > 0 } {
- ui_notice "The following ports are currently installed:"
- foreach i [portlist_sortint $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]
- set extra ""
- set nvariants ""
- if {[macports::ui_isset ports_verbose]} {
- set regref [registry::open_entry $iname $iversion $irevision $ivariants [lindex $i 5]]
- set nvariants [registry::property_retrieve $regref negated_variants]
- if {$nvariants == 0} {
- set nvariants ""
- }
- set os_platform [registry::property_retrieve $regref os_platform]
- set os_major [registry::property_retrieve $regref os_major]
- set archs [registry::property_retrieve $regref archs]
- if {$os_platform != 0 && $os_platform ne "" && $os_major != 0 && $os_major ne ""} {
- append extra " platform='$os_platform $os_major'"
- }
- if {$archs != 0 && $archs ne ""} {
- append extra " archs='$archs'"
- }
- }
- if { $iactive == 0 } {
- puts " $iname @${iversion}_${irevision}${ivariants}${nvariants}${extra}"
- } elseif { $iactive == 1 } {
- puts " $iname @${iversion}_${irevision}${ivariants}${nvariants} (active)${extra}"
- }
- }
- } elseif { $restrictedList } {
- ui_notice "None of the specified ports are installed."
- } else {
- ui_notice "No ports are installed."
- }
-
- return $status
-}
-
-
-proc action_outdated { action portlist opts } {
- global private_options
- set status 0
-
- # If port names were supplied, limit ourselves to those ports, else check all installed ports
- set ilist {}
- set restrictedList 0
- if { [llength $portlist] || (![info exists private_options(ports_no_args)] || $private_options(ports_no_args) eq "no")} {
- set restrictedList 1
- foreach portspec $portlist {
- array set port $portspec
- set portname $port(name)
- set composite_version [composite_version $port(version) $port(variants)]
- if { [catch {set ilist [concat $ilist [registry::installed $portname $composite_version]]} result] } {
- if {![string match "* not registered as installed." $result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port outdated failed: $result" 1 status
- }
- }
- }
- } else {
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- ui_error "port installed failed: $result"
- set status 1
- }
- }
- }
-
- set num_outdated 0
- if { [llength $ilist] > 0 } {
- foreach i [portlist_sortint $ilist] {
-
- # Get information about the installed port
- set portname [lindex $i 0]
- set installed_version [lindex $i 1]
- set installed_revision [lindex $i 2]
- set installed_compound "${installed_version}_${installed_revision}"
-
- set is_active [lindex $i 4]
- if {$is_active == 0} {
- continue
- }
- set installed_epoch [lindex $i 5]
-
- # Get info about the port from the index
- if {[catch {set res [mportlookup $portname]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "search for portname $portname failed: $result" 1 status
- }
- if {[llength $res] < 2} {
- if {[macports::ui_isset ports_debug]} {
- puts "$portname ($installed_compound is installed; the port was not found in the port index)"
- }
- continue
- }
- array unset portinfo
- array set portinfo [lindex $res 1]
-
- # Get information about latest available version and revision
- if {![info exists portinfo(version)]} {
- ui_warn "$portname has no version field"
- continue
- }
- set latest_version $portinfo(version)
- set latest_revision 0
- if {[info exists portinfo(revision)] && $portinfo(revision) > 0} {
- set latest_revision $portinfo(revision)
- }
- set latest_compound "${latest_version}_${latest_revision}"
- set latest_epoch 0
- if {[info exists portinfo(epoch)]} {
- set latest_epoch $portinfo(epoch)
- }
-
- # Compare versions, first checking epoch, then version, then revision
- set epoch_comp_result [expr {$installed_epoch - $latest_epoch}]
- set comp_result [vercmp $installed_version $latest_version]
- if { $comp_result == 0 } {
- set comp_result [expr {$installed_revision - $latest_revision}]
- }
- set reason ""
- if {$epoch_comp_result != 0 && $installed_version != $latest_version} {
- if {($comp_result >= 0 && $epoch_comp_result < 0) || ($comp_result <= 0 && $epoch_comp_result > 0)} {
- set reason { (epoch $installed_epoch $relation $latest_epoch)}
- }
- set comp_result $epoch_comp_result
- } elseif {$comp_result == 0} {
- set regref [registry::open_entry $portname $installed_version $installed_revision [lindex $i 3] $installed_epoch]
- set os_platform_installed [registry::property_retrieve $regref os_platform]
- set os_major_installed [registry::property_retrieve $regref os_major]
- if {$os_platform_installed ne "" && $os_platform_installed != 0
- && $os_major_installed ne "" && $os_major_installed != 0
- && ($os_platform_installed != ${macports::os_platform} || $os_major_installed != ${macports::os_major})} {
- set comp_result -1
- set reason { (platform $os_platform_installed $os_major_installed != ${macports::os_platform} ${macports::os_major})}
- }
- }
-
- # Report outdated (or, for verbose, predated) versions
- if { $comp_result != 0 } {
-
- # Form a relation between the versions
- set flag ""
- if { $comp_result > 0 } {
- set relation ">"
- set flag "!"
- } else {
- set relation "<"
- }
-
- # Emit information
- if {$comp_result < 0 || [macports::ui_isset ports_verbose]} {
-
- if {$num_outdated == 0} {
- ui_notice "The following installed ports are outdated:"
- }
- incr num_outdated
-
- puts [format "%-30s %-24s %1s" $portname "$installed_compound $relation $latest_compound [subst $reason]" $flag]
- }
-
- }
- }
-
- if {$num_outdated == 0} {
- ui_notice "No installed ports are outdated."
- }
- } elseif { $restrictedList } {
- ui_notice "None of the specified ports are outdated."
- } else {
- ui_notice "No ports are installed."
- }
-
- return $status
-}
-
-
-proc action_contents { action portlist opts } {
- global global_options
- if {[require_portlist portlist]} {
- return 1
- }
- if {[info exists global_options(ports_contents_size)]} {
- set units {}
- if {[info exists global_options(ports_contents_units)]} {
- set units [complete_size_units $global_options(ports_contents_units)]
- }
- set outstring {[format "%12s $file" [filesize $file $units]]}
- } else {
- set outstring { $file}
- }
-
- foreachport $portlist {
- if { ![catch {set ilist [registry::installed $portname]} result] } {
- # set portname again since the one we were passed may not have had the correct case
- set portname [lindex $ilist 0 0]
- }
- set files [registry::port_registered $portname]
- if { $files != 0 } {
- if { [llength $files] > 0 } {
- ui_notice "Port $portname contains:"
- foreach file $files {
- puts [subst $outstring]
- }
- } else {
- ui_notice "Port $portname does not contain any files or is not active."
- }
- } else {
- ui_notice "Port $portname is not installed."
- }
- }
- registry::close_file_map
-
- return 0
-}
-
-# expand abbreviations of size units
-proc complete_size_units {units} {
- if {$units eq "K" || $units eq "Ki"} {
- return "KiB"
- } elseif {$units eq "k"} {
- return "kB"
- } elseif {$units eq "Mi"} {
- return "MiB"
- } elseif {$units eq "M"} {
- return "MB"
- } elseif {$units eq "Gi"} {
- return "GiB"
- } elseif {$units eq "G"} {
- return "GB"
- } else {
- return $units
- }
-}
-
-# Show space used by the given ports' files
-proc action_space {action portlist opts} {
- global global_options
- require_portlist portlist
-
- set units {}
- if {[info exists global_options(ports_space_units)]} {
- set units [complete_size_units $global_options(ports_space_units)]
- }
- set spaceall 0.0
- foreachport $portlist {
- set space 0.0
- set files [registry::port_registered $portname]
- if { $files != 0 } {
- if { [llength $files] > 0 } {
- foreach file $files {
- catch {
- set space [expr {$space + [file size $file]}]
- }
- }
- if {![info exists options(ports_space_total)] || $options(ports_space_total) ne "yes"} {
- set msg "[bytesize $space $units] $portname"
- if { $portversion != {} } {
- append msg " @$portversion"
- }
- puts $msg
- }
- set spaceall [expr {$space + $spaceall}]
- } else {
- puts stderr "Port $portname does not contain any file or is not active."
- }
- } else {
- puts stderr "Port $portname is not installed."
- }
- }
- if {[llength $portlist] > 1 || ([info exists options(ports_space_total)] && $options(ports_space_total) eq "yes")} {
- puts "[bytesize $spaceall $units] total"
- }
- return 0
-}
-
-proc action_variants { action portlist opts } {
- global global_variations
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
- foreachport $portlist {
- array unset portinfo
- if {$porturl eq ""} {
- # look up port
- if {[catch {mportlookup $portname} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Port $portname not found" 1 status
- }
-
- array set portinfo [lindex $result 1]
-
- set porturl $portinfo(porturl)
- set portdir $portinfo(portdir)
- }
-
- if {!([info exists options(ports_variants_index)] && $options(ports_variants_index) eq "yes")} {
- if {![info exists options(subport)]} {
- if {[info exists portinfo(name)]} {
- set options(subport) $portinfo(name)
- } else {
- set options(subport) $portname
- }
- }
- if {[catch {set mport [mportopen $porturl [array get options] [array get variations]]} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Unable to open port: $result" 1 status
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
- if {[info exists portdir]} {
- set portinfo(portdir) $portdir
- }
- } elseif {![info exists portinfo]} {
- ui_warn "port variants --index does not work with 'current' pseudo-port"
- continue
- }
-
- # set portname again since the one we were passed may not have had the correct case
- set portname $portinfo(name)
-
- # if this fails the port doesn't have any variants
- if {![info exists portinfo(variants)]} {
- ui_notice "$portname has no variants"
- } else {
- array unset vinfo
- # Use the new format if it exists.
- if {[info exists portinfo(vinfo)]} {
- array set vinfo $portinfo(vinfo)
- # Otherwise fall back to the old format.
- } elseif {[info exists portinfo(variant_desc)]} {
- array set vdescriptions $portinfo(variant_desc)
- }
-
- # print out all the variants
- ui_notice "$portname has the variants:"
- foreach v [lsort $portinfo(variants)] {
- unset -nocomplain vconflicts vdescription vrequires
- set varmodifier " "
- # Retrieve variants' information from the new format.
- if {[info exists vinfo]} {
- array unset variant
- array set variant $vinfo($v)
-
- # Retrieve conflicts, description, is_default, and
- # vrequires.
- if {[info exists variant(conflicts)]} {
- set vconflicts $variant(conflicts)
- }
- if {[info exists variant(description)]} {
- set vdescription $variant(description)
- }
-
- # XXX Keep these varmodifiers in sync with action_info, or create a wrapper for it
- if {[info exists variations($v)]} {
- set varmodifier " $variations($v)"
- } elseif {[info exists global_variations($v)]} {
- # selected by variants.conf, prefixed with (+)/(-)
- set varmodifier "($global_variations($v))"
- } elseif {[info exists variant(is_default)]} {
- set varmodifier "\[$variant(is_default)\]"
- }
- if {[info exists variant(requires)]} {
- set vrequires $variant(requires)
- }
- # Retrieve variants' information from the old format,
- # which only consists of the description.
- } elseif {[info exists vdescriptions($v)]} {
- set vdescription $vdescriptions($v)
- }
-
- if {[info exists vdescription]} {
- puts [wraplabel "$varmodifier$v" [string trim $vdescription] 0 [string repeat " " [expr 5 + [string length $v]]]]
- } else {
- puts "$varmodifier$v"
- }
- if {[info exists vconflicts]} {
- puts " * conflicts with [string trim $vconflicts]"
- }
- if {[info exists vrequires]} {
- puts " * requires [string trim $vrequires]"
- }
- }
- }
- }
-
- return $status
-}
-
-
-proc action_search { action portlist opts } {
- global private_options global_options
- set status 0
- if {![llength $portlist] && [info exists private_options(ports_no_args)] && $private_options(ports_no_args) eq "yes"} {
- ui_error "You must specify a search pattern"
- return 1
- }
-
- # Copy global options as we are going to modify the array
- array set options [array get global_options]
-
- if {[info exists options(ports_search_depends)] && $options(ports_search_depends) eq "yes"} {
- array unset options ports_search_depends
- set options(ports_search_depends_fetch) yes
- set options(ports_search_depends_extract) yes
- set options(ports_search_depends_build) yes
- set options(ports_search_depends_lib) yes
- set options(ports_search_depends_run) yes
- }
-
- # Array to hold given filters
- array set filters {}
- # Default matchstyle
- set filter_matchstyle "none"
- set filter_case no
- foreach { option } [array names options ports_search_*] {
- set opt [string range $option 13 end]
-
- if { $options($option) ne "yes" } {
- continue
- }
- switch -- $opt {
- exact -
- glob {
- set filter_matchstyle $opt
- continue
- }
- regex {
- set filter_matchstyle regexp
- continue
- }
- case-sensitive {
- set filter_case yes
- continue
- }
- line {
- continue
- }
- }
-
- set filters($opt) "yes"
- }
- # Set default search filter if none was given
- if { [array size filters] == 0 } {
- set filters(name) "yes"
- set filters(description) "yes"
- }
-
- set separator ""
- foreach portname $portlist {
- puts -nonewline $separator
-
- set searchstring $portname
- set matchstyle $filter_matchstyle
- if {$matchstyle eq "none"} {
- # Guess if the given string was a glob expression, if not do a substring search
- if {[string first "*" $portname] == -1 && [string first "?" $portname] == -1} {
- set searchstring "*$portname*"
- }
- set matchstyle glob
- }
-
- set res {}
- set portfound 0
- foreach { opt } [array get filters] {
- # Map from friendly name
- set opt [map_friendly_field_names $opt]
-
- if {[catch {eval set matches \[mportsearch \$searchstring $filter_case \$matchstyle $opt\]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "search for name $portname failed: $result" 1 status
- }
-
- set tmp {}
- foreach {name info} $matches {
- add_to_portlist tmp [concat [list name $name] $info]
- }
- set res [opUnion $res $tmp]
- }
- set res [portlist_sort $res]
-
- set joiner ""
- foreach info $res {
- array unset portinfo
- array set portinfo $info
-
- # XXX is this the right place to verify an entry?
- if {![info exists portinfo(name)]} {
- puts stderr "Invalid port entry, missing portname"
- continue
- }
- if {![info exists portinfo(description)]} {
- puts stderr "Invalid port entry for $portinfo(name), missing description"
- continue
- }
- if {![info exists portinfo(version)]} {
- puts stderr "Invalid port entry for $portinfo(name), missing version"
- continue
- }
-
- if {[macports::ui_isset ports_quiet]} {
- puts $portinfo(name)
- } else {
- if {[info exists options(ports_search_line)]
- && $options(ports_search_line) eq "yes"} {
- # check for ports without category, e.g. replaced_by stubs
- if {[info exists portinfo(categories)]} {
- puts "$portinfo(name)\t$portinfo(version)\t$portinfo(categories)\t$portinfo(description)"
- } else {
- # keep two consecutive tabs in order to provide consistent columns' content
- puts "$portinfo(name)\t$portinfo(version)\t\t$portinfo(description)"
- }
- } else {
- puts -nonewline $joiner
-
- puts -nonewline "$portinfo(name) @$portinfo(version)"
- if {[info exists portinfo(revision)] && $portinfo(revision) > 0} {
- puts -nonewline "_$portinfo(revision)"
- }
- if {[info exists portinfo(categories)]} {
- puts -nonewline " ([join $portinfo(categories) ", "])"
- }
- puts ""
- puts [wrap [join $portinfo(description)] 0 [string repeat " " 4]]
- }
- }
-
- set joiner "\n"
- set portfound 1
- }
- if { !$portfound } {
- ui_notice "No match for $portname found"
- } elseif {[llength $res] > 1} {
- if {(![info exists global_options(ports_search_line)]
- || $global_options(ports_search_line) ne "yes")} {
- ui_notice "\nFound [llength $res] ports."
- }
- }
-
- set separator "--\n"
- }
-
- array unset options
- array unset filters
-
- return $status
-}
-
-
-proc action_list { action portlist opts } {
- global private_options
- set status 0
-
- # Default to list all ports if no portnames are supplied
- if { ![llength $portlist] && [info exists private_options(ports_no_args)] && $private_options(ports_no_args) eq "yes"} {
- add_to_portlist portlist [list name "-all-"]
- }
-
- foreachport $portlist {
- if {$portname eq "-all-"} {
- if {[catch {set res [mportlistall]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "listing all ports failed: $result" 1 status
- }
- } else {
- set search_string [regex_pat_sanitize $portname]
- if {[catch {set res [mportsearch ^$search_string\$ no]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "search for portname $search_string failed: $result" 1 status
- }
- }
-
- foreach {name array} $res {
- array unset portinfo
- array set portinfo $array
- set outdir ""
- if {[info exists portinfo(portdir)]} {
- set outdir $portinfo(portdir)
- }
- puts [format "%-30s @%-14s %s" $portinfo(name) $portinfo(version) $outdir]
- }
- }
-
- return $status
-}
-
-
-proc action_echo { action portlist opts } {
- global global_options
-
- # Simply echo back the port specs given to this command
- foreachport $portlist {
- if {![macports::ui_isset ports_quiet]} {
- set opts {}
- foreach { key value } [array get options] {
- if {![info exists global_options($key)]} {
- lappend opts "$key=$value"
- }
- }
-
- set composite_version [composite_version $portversion [array get variations] 1]
- if { $composite_version ne "" } {
- set ver_field "@$composite_version"
- } else {
- set ver_field ""
- }
- puts [format "%-30s %s %s" $portname $ver_field [join $opts " "]]
- } else {
- puts "$portname"
- }
- }
-
- return 0
-}
-
-
-proc action_portcmds { action portlist opts } {
- # Operations on the port's directory and Portfile
- global env boot_env current_portdir
-
- array set local_options $opts
-
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
- foreachport $portlist {
- array unset portinfo
- # If we have a url, use that, since it's most specific, otherwise try to map the portname to a url
- if {$porturl eq ""} {
-
- # Verify the portname, getting portinfo to map to a porturl
- if {[catch {set res [mportlookup $portname]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $res] < 2} {
- break_softcontinue "Port $portname not found" 1 status
- }
- array set portinfo [lindex $res 1]
- set porturl $portinfo(porturl)
- set portname $portinfo(name)
- }
-
-
- # Calculate portdir, porturl, and portfile from initial porturl
- set portdir [file normalize [macports::getportdir $porturl]]
- set porturl "file://${portdir}"; # Rebuild url so it's fully qualified
- set portfile "${portdir}/Portfile"
-
- # Now execute the specific action
- if {[file readable $portfile]} {
- switch -- $action {
- cat {
- # Copy the portfile to standard output
- set f [open $portfile RDONLY]
- while { ![eof $f] } {
- puts -nonewline [read $f 4096]
- }
- close $f
- }
-
- edit {
- # Edit the port's portfile with the user's editor
-
- # Restore our entire environment from start time.
- # We need it to evaluate the editor, and the editor
- # may want stuff from it as well, like TERM.
- array unset env_save; array set env_save [array get env]
- array unset env *
- if {${macports::macosx_version} eq "10.5"} {
- unsetenv *
- }
- array set env [array get boot_env]
-
- # Find an editor to edit the portfile
- set editor ""
- set editor_var "ports_${action}_editor"
- if {[info exists local_options($editor_var)]} {
- set editor [join $local_options($editor_var)]
- } else {
- foreach ed { MP_EDITOR VISUAL EDITOR } {
- if {[info exists env($ed)]} {
- set editor $env($ed)
- break
- }
- }
- }
-
- # Use a reasonable canned default if no editor specified or set in env
- if { $editor eq "" } { set editor "/usr/bin/vi" }
-
- # Invoke the editor
- if {[catch {eval exec >@stdout <@stdin 2>@stderr $editor {$portfile}} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "unable to invoke editor $editor: $result" 1 status
- }
-
- # Restore internal MacPorts environment
- array unset env *
- if {${macports::macosx_version} eq "10.5"} {
- unsetenv *
- }
- array set env [array get env_save]
- }
-
- dir {
- # output the path to the port's directory
- puts $portdir
- }
-
- work {
- # output the path to the port's work directory
- set workpath [macports::getportworkpath_from_portdir $portdir $portname]
- if {[file exists $workpath]} {
- puts $workpath
- }
- }
-
- cd {
- # Change to the port's directory, making it the default
- # port for any future commands
- set current_portdir $portdir
- }
-
- url {
- # output the url of the port's directory, suitable to feed back in later as a port descriptor
- puts $porturl
- }
-
- file {
- # output the path to the port's portfile
- puts $portfile
- }
-
- logfile {
- set logfile [file join [macports::getportlogpath $portdir $portname] "main.log"]
- if {[file isfile $logfile]} {
- puts $logfile
- } else {
- ui_error "Log file not found for port in $portdir"
- }
- }
-
- gohome {
- set homepage ""
-
- # Get the homepage as read from PortIndex
- if {[info exists portinfo(homepage)]} {
- set homepage $portinfo(homepage)
- }
-
- # If not available, get the homepage for the port by opening the Portfile
- if {$homepage eq "" && ![catch {set ctx [mportopen $porturl]} result]} {
- array set portinfo [mportinfo $ctx]
- if {[info exists portinfo(homepage)]} {
- set homepage $portinfo(homepage)
- }
- mportclose $ctx
- }
-
- # Try to open a browser to the homepage for the given port
- if { $homepage ne "" } {
- if {[catch {system "${macports::autoconf::open_path} '$homepage'"} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "unable to invoke browser using ${macports::autoconf::open_path}: $result" 1 status
- }
- } else {
- ui_error [format "No homepage for %s" $portname]
- }
- }
- }
- } else {
- break_softcontinue "Could not read $portfile" 1 status
- }
- }
-
- return $status
-}
-
-
-proc action_sync { action portlist opts } {
- global global_options
-
- set status 0
- if {[catch {mportsync [array get global_options]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- ui_msg "port sync failed: $result"
- set status 1
- }
-
- return $status
-}
-
-
-proc action_target { action portlist opts } {
- global global_variations
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
- if {($action eq "install" || $action eq "archive") && [prefix_unwritable] && ![macports::global_option_isset ports_dryrun]} {
- return 1
- }
- foreachport $portlist {
- array unset portinfo
- # If we have a url, use that, since it's most specific
- # otherwise try to map the portname to a url
- if {$porturl eq ""} {
- # Verify the portname, getting portinfo to map to a porturl
- if {[catch {set res [mportlookup $portname]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $res] < 2} {
- # don't error for ports that are installed but not in the tree
- if {[registry::entry_exists_for_name $portname]} {
- ui_warn "Skipping $portname (not in the ports tree)"
- continue
- } else {
- break_softcontinue "Port $portname not found" 1 status
- }
- }
- array set portinfo [lindex $res 1]
- set porturl $portinfo(porturl)
- }
-
- # use existing variants iff none were explicitly requested
- if {[array get requested_variations] eq "" && [array get variations] ne ""} {
- array unset requested_variations
- array set requested_variations [array get variations]
- }
-
- # Add any global_variations to the variations
- # specified for the port
- foreach { variation value } [array get global_variations] {
- if { ![info exists requested_variations($variation)] } {
- set requested_variations($variation) $value
- }
- }
-
- # If version was specified, save it as a version glob for use
- # in port actions (e.g. clean).
- if {[string length $portversion]} {
- set options(ports_version_glob) $portversion
- }
- # if installing, mark the port as explicitly requested
- if {$action eq "install"} {
- if {![info exists options(ports_install_unrequested)]} {
- set options(ports_requested) 1
- }
- # we actually activate as well
- set target activate
- } elseif {$action eq "archive"} {
- set target install
- } else {
- set target $action
- }
- if {![info exists options(subport)]} {
- if {[info exists portinfo(name)]} {
- set options(subport) $portinfo(name)
- } else {
- set options(subport) $portname
- }
- }
- if {[catch {set workername [mportopen $porturl [array get options] [array get requested_variations]]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "Unable to open port: $result" 1 status
- }
- if {[catch {set result [mportexec $workername $target]} result]} {
- global errorInfo
- mportclose $workername
- ui_debug "$errorInfo"
- break_softcontinue "Unable to execute port: $result" 1 status
- }
-
- mportclose $workername
-
- # Process any error that wasn't thrown and handled already
- if {$result} {
- print_tickets_url
- break_softcontinue "Processing of port $portname failed" 1 status
- }
- }
-
- if {$status == 0 && $action eq "install" && ![macports::global_option_isset ports_dryrun]} {
- array set options $opts
- if {![info exists options(ports_nodeps)] && ![info exists options(ports_install_no-rev-upgrade)] && ${macports::revupgrade_autorun}} {
- set status [action_revupgrade $action $portlist $opts]
- }
- }
-
- return $status
-}
-
-
-proc action_exit { action portlist opts } {
- # Return a semaphore telling the main loop to quit
- return -999
-}
-
-
-##########################################
-# Command Parsing
-##########################################
-proc moreargs {} {
- global cmd_argn cmd_argc
- return [expr {$cmd_argn < $cmd_argc}]
-}
-
-
-proc lookahead {} {
- global cmd_argn cmd_argc cmd_argv
- if {$cmd_argn < $cmd_argc} {
- return [lindex $cmd_argv $cmd_argn]
- } else {
- return _EOF_
- }
-}
-
-
-proc advance {} {
- global cmd_argn
- incr cmd_argn
-}
-
-
-proc match s {
- if {[lookahead] == $s} {
- advance
- return 1
- }
- return 0
-}
-
-# action_array specifies which action to run on the given command
-# and if the action wants an expanded portlist.
-# The value is a list of the form {action expand},
-# where action is a string and expand a value:
-# 0 none Does not expect any text argument
-# 1 strings Expects some strings as text argument
-# 2 ports Wants an expanded list of ports as text argument
-global action_array
-
-# Define global constants
-const ACTION_ARGS_NONE 0
-const ACTION_ARGS_STRINGS 1
-const ACTION_ARGS_PORTS 2
-
-array set action_array [list \
- usage [list action_usage [ACTION_ARGS_STRINGS]] \
- help [list action_help [ACTION_ARGS_STRINGS]] \
- \
- echo [list action_echo [ACTION_ARGS_PORTS]] \
- \
- info [list action_info [ACTION_ARGS_PORTS]] \
- location [list action_location [ACTION_ARGS_PORTS]] \
- notes [list action_notes [ACTION_ARGS_PORTS]] \
- provides [list action_provides [ACTION_ARGS_STRINGS]] \
- log [list action_log [ACTION_ARGS_PORTS]] \
- \
- activate [list action_activate [ACTION_ARGS_PORTS]] \
- deactivate [list action_deactivate [ACTION_ARGS_PORTS]] \
- \
- select [list action_select [ACTION_ARGS_STRINGS]] \
- \
- sync [list action_sync [ACTION_ARGS_NONE]] \
- selfupdate [list action_selfupdate [ACTION_ARGS_NONE]] \
- \
- setrequested [list action_setrequested [ACTION_ARGS_PORTS]] \
- unsetrequested [list action_setrequested [ACTION_ARGS_PORTS]] \
- \
- upgrade [list action_upgrade [ACTION_ARGS_PORTS]] \
- rev-upgrade [list action_revupgrade [ACTION_ARGS_NONE]] \
- reclaim [list action_reclaim [ACTION_ARGS_NONE]] \
- doctor [list action_doctor [ACTION_ARGS_NONE]] \
- \
- version [list action_version [ACTION_ARGS_NONE]] \
- platform [list action_platform [ACTION_ARGS_NONE]] \
- \
- uninstall [list action_uninstall [ACTION_ARGS_PORTS]] \
- \
- installed [list action_installed [ACTION_ARGS_PORTS]] \
- outdated [list action_outdated [ACTION_ARGS_PORTS]] \
- contents [list action_contents [ACTION_ARGS_PORTS]] \
- space [list action_space [ACTION_ARGS_PORTS]] \
- dependents [list action_dependents [ACTION_ARGS_PORTS]] \
- rdependents [list action_dependents [ACTION_ARGS_PORTS]] \
- deps [list action_deps [ACTION_ARGS_PORTS]] \
- rdeps [list action_deps [ACTION_ARGS_PORTS]] \
- variants [list action_variants [ACTION_ARGS_PORTS]] \
- \
- search [list action_search [ACTION_ARGS_STRINGS]] \
- list [list action_list [ACTION_ARGS_PORTS]] \
- \
- edit [list action_portcmds [ACTION_ARGS_PORTS]] \
- cat [list action_portcmds [ACTION_ARGS_PORTS]] \
- dir [list action_portcmds [ACTION_ARGS_PORTS]] \
- work [list action_portcmds [ACTION_ARGS_PORTS]] \
- cd [list action_portcmds [ACTION_ARGS_PORTS]] \
- url [list action_portcmds [ACTION_ARGS_PORTS]] \
- file [list action_portcmds [ACTION_ARGS_PORTS]] \
- logfile [list action_portcmds [ACTION_ARGS_PORTS]] \
- gohome [list action_portcmds [ACTION_ARGS_PORTS]] \
- \
- fetch [list action_target [ACTION_ARGS_PORTS]] \
- checksum [list action_target [ACTION_ARGS_PORTS]] \
- extract [list action_target [ACTION_ARGS_PORTS]] \
- patch [list action_target [ACTION_ARGS_PORTS]] \
- configure [list action_target [ACTION_ARGS_PORTS]] \
- build [list action_target [ACTION_ARGS_PORTS]] \
- destroot [list action_target [ACTION_ARGS_PORTS]] \
- install [list action_target [ACTION_ARGS_PORTS]] \
- clean [list action_target [ACTION_ARGS_PORTS]] \
- test [list action_target [ACTION_ARGS_PORTS]] \
- lint [list action_target [ACTION_ARGS_PORTS]] \
- livecheck [list action_target [ACTION_ARGS_PORTS]] \
- distcheck [list action_target [ACTION_ARGS_PORTS]] \
- mirror [list action_target [ACTION_ARGS_PORTS]] \
- load [list action_target [ACTION_ARGS_PORTS]] \
- unload [list action_target [ACTION_ARGS_PORTS]] \
- distfiles [list action_target [ACTION_ARGS_PORTS]] \
- \
- archivefetch [list action_target [ACTION_ARGS_PORTS]] \
- archive [list action_target [ACTION_ARGS_PORTS]] \
- unarchive [list action_target [ACTION_ARGS_PORTS]] \
- dmg [list action_target [ACTION_ARGS_PORTS]] \
- mdmg [list action_target [ACTION_ARGS_PORTS]] \
- dpkg [list action_target [ACTION_ARGS_PORTS]] \
- mpkg [list action_target [ACTION_ARGS_PORTS]] \
- pkg [list action_target [ACTION_ARGS_PORTS]] \
- portpkg [list action_target [ACTION_ARGS_PORTS]] \
- rpm [list action_target [ACTION_ARGS_PORTS]] \
- srpm [list action_target [ACTION_ARGS_PORTS]] \
- \
- quit [list action_exit [ACTION_ARGS_NONE]] \
- exit [list action_exit [ACTION_ARGS_NONE]] \
-]
-
-# Expand "action".
-# Returns an action proc, or a list of matching action procs, or the action passed in
-proc find_action { action } {
- global action_array
-
- if { ! [info exists action_array($action)] } {
- set guess [guess_action $action]
- if { [info exists action_array($guess)] } {
- return $guess
- }
- return $guess
- }
-
- return $action
-}
-
-# Expand action
-# If there's more than one match, return the next possibility
-proc find_action_proc { action } {
- global action_array
-
- set action_proc ""
- if { [info exists action_array($action)] } {
- set action_proc [lindex $action_array($action) 0]
- } else {
- set action [complete_action $action]
- if { [info exists action_array($action)] } {
- set action_proc [lindex $action_array($action) 0]
- }
- }
-
- return $action_proc
-}
-
-proc get_action_proc { action } {
- global action_array
-
- set action_proc ""
- if { [info exists action_array($action)] } {
- set action_proc [lindex $action_array($action) 0]
- }
-
- return $action_proc
-}
-
-# Returns whether an action expects text arguments at all,
-# expects text arguments or wants an expanded list of ports
-# Return values are constants:
-# [ACTION_ARGS_NONE] Does not expect any text argument
-# [ACTION_ARGS_STRINGS] Expects some strings as text argument
-# [ACTION_ARGS_PORTS] Wants an expanded list of ports as text argument
-proc action_needs_portlist { action } {
- global action_array
-
- set ret 0
- if {[info exists action_array($action)]} {
- set ret [lindex $action_array($action) 1]
- }
-
- return $ret
-}
-
-# cmd_opts_array specifies which arguments the commands accept
-# Commands not listed here do not accept any arguments
-# Syntax if {option argn}
-# Where option is the name of the option and argn specifies how many arguments
-# this argument takes
-global cmd_opts_array
-array set cmd_opts_array {
- edit {{editor 1}}
- info {category categories depends_fetch depends_extract
- depends_build depends_lib depends_run
- depends description epoch fullname heading homepage index license
- line long_description
- maintainer maintainers name platform platforms portdir pretty
- replaced_by revision subports variant variants version}
- contents {size {units 1}}
- deps {index no-build}
- rdeps {index no-build full}
- rdependents {full}
- search {case-sensitive category categories depends_fetch
- depends_extract depends_build depends_lib depends_run
- depends description epoch exact glob homepage line
- long_description maintainer maintainers name platform
- platforms portdir regex revision variant variants version}
- selfupdate {nosync}
- space {{units 1} total}
- activate {no-exec}
- deactivate {no-exec}
- install {no-rev-upgrade unrequested}
- uninstall {follow-dependents follow-dependencies no-exec}
- variants {index}
- clean {all archive dist work logs}
- mirror {new}
- lint {nitpick}
- select {list set show summary}
- log {{phase 1} {level 1}}
- upgrade {force enforce-variants no-replace no-rev-upgrade}
- rev-upgrade {id-loadcmd-check}
-}
-
-##
-# Checks whether the given option is valid
-#
-# @param action for which action
-# @param option the prefix of the option to check
-# @return list of pairs {name argc} for all matching options
-proc cmd_option_matches {action option} {
- global cmd_opts_array
-
- # This could be so easy with lsearch -index,
- # but that's only available as of Tcl 8.5
-
- if {![info exists cmd_opts_array($action)]} {
- return {}
- }
-
- set result {}
-
- foreach item $cmd_opts_array($action) {
- if {[llength $item] == 1} {
- set name $item
- set argc 0
- } else {
- set name [lindex $item 0]
- set argc [lindex $item 1]
- }
-
- if {$name == $option} {
- set result [list [list $name $argc]]
- break
- } elseif {[string first $option $name] == 0} {
- lappend result [list $name $argc]
- }
- }
-
- return $result
-}
-
-# Parse global options
-#
-# Note that this is called several times:
-# (1) Initially, to parse options that will be constant across all commands
-# (options that come prior to any command, frozen into global_options_base)
-# (2) Following each command (to parse options that will be unique to that command
-# (the global_options array is reset to global_options_base prior to each command)
-#
-proc parse_options { action ui_options_name global_options_name } {
- upvar $ui_options_name ui_options
- upvar $global_options_name global_options
- global cmdname cmd_opts_array
-
- while {[moreargs]} {
- set arg [lookahead]
-
- if {[string index $arg 0] ne "-"} {
- break
- } elseif {[string index $arg 1] eq "-"} {
- # Process long arguments
- switch -- $arg {
- -- { # This is the options terminator; do no further option processing
- advance; break
- }
- default {
- set key [string range $arg 2 end]
- set kopts [cmd_option_matches $action $key]
- if {[llength $kopts] == 0} {
- return -code error "${action} does not accept --${key}"
- } elseif {[llength $kopts] > 1} {
- set errlst {}
- foreach e $kopts {
- lappend errlst "--[lindex $e 0]"
- }
- return -code error "\"port ${action} --${key}\" is ambiguous: \n port ${action} [join $errlst "\n port ${action} "]"
- }
- set key [lindex $kopts 0 0]
- set kargc [lindex $kopts 0 1]
- if {$kargc == 0} {
- set global_options(ports_${action}_${key}) yes
- } else {
- set args {}
- while {[moreargs] && $kargc > 0} {
- advance
- lappend args [lookahead]
- set kargc [expr {$kargc - 1}]
- }
- if {$kargc > 0} {
- return -code error "--${key} expects [expr {$kargc + [llength $args]}] parameters!"
- }
- set global_options(ports_${action}_${key}) $args
- }
- }
- }
- } else {
- # Process short arg(s)
- set opts [string range $arg 1 end]
- foreach c [split $opts {}] {
- switch -- $c {
- v {
- set ui_options(ports_verbose) yes
- }
- d {
- set ui_options(ports_debug) yes
- # debug implies verbose
- set ui_options(ports_verbose) yes
- }
- q {
- set ui_options(ports_quiet) yes
- }
- p {
- # Ignore errors while processing within a command
- set ui_options(ports_processall) yes
- }
- f {
- set global_options(ports_force) yes
- }
- o {
- set global_options(ports_ignore_different) yes
- }
- n {
- set global_options(ports_nodeps) yes
- }
- u {
- set global_options(port_uninstall_old) yes
- }
- R {
- set global_options(ports_do_dependents) yes
- }
- s {
- set global_options(ports_source_only) yes
- }
- b {
- set global_options(ports_binary_only) yes
- }
- c {
- set global_options(ports_autoclean) yes
- }
- k {
- set global_options(ports_autoclean) no
- }
- t {
- set global_options(ports_trace) yes
- }
- y {
- set global_options(ports_dryrun) yes
- }
- F {
- # Name a command file to process
- advance
- if {[moreargs]} {
- lappend ui_options(ports_commandfiles) [lookahead]
- }
- }
- D {
- advance
- if {[moreargs]} {
- cd [lookahead]
- }
- break
- }
- default {
- print_usage; exit 1
- }
- }
- }
- }
-
- advance
- }
-}
-
-# acquire exclusive registry lock for actions that need it
-# returns 1 if locked, 0 otherwise
-proc lock_reg_if_needed {action} {
- switch -- $action {
- activate -
- deactivate -
- setrequested -
- unsetrequested -
- upgrade -
- uninstall -
- install {
- registry::exclusive_lock
- return 1
- }
- }
- return 0
-}
-
-proc process_cmd { argv } {
- global cmd_argc cmd_argv cmd_argn \
- global_options global_options_base private_options ui_options \
- current_portdir
- set cmd_argv $argv
- set cmd_argc [llength $argv]
- set cmd_argn 0
-
- set action_status 0
-
- # Process an action if there is one
- while {($action_status == 0 || [macports::ui_isset ports_processall]) && [moreargs]} {
- set action [lookahead]
- advance
-
- # Handle command separator
- if { $action == ";" } {
- continue
- }
-
- # Handle a comment
- if { [string index $action 0] == "#" } {
- while { [moreargs] } { advance }
- break
- }
-
- set locked [lock_reg_if_needed $action]
- # Always start out processing an action in current_portdir
- cd $current_portdir
-
- # Reset global_options from base before each action, as we munge it just below...
- array unset global_options
- array set global_options $global_options_base
-
- # Find an action to execute
- set actions [find_action $action]
- if {[llength $actions] == 1} {
- set action [lindex $actions 0]
- set action_proc [get_action_proc $action]
- } else {
- if {[llength $actions] > 1} {
- ui_error "\"port ${action}\" is ambiguous: \n port [join $actions "\n port "]"
- } else {
- ui_error "Unrecognized action \"port $action\""
- }
- set action_status 1
- break
- }
-
- # Parse options that will be unique to this action
- # (to avoid abiguity with -variants and a default port, either -- must be
- # used to terminate option processing, or the pseudo-port current must be specified).
- if {[catch {parse_options $action ui_options global_options} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- ui_error $result
- set action_status 1
- break
- }
-
- # What kind of arguments does the command expect?
- set expand [action_needs_portlist $action]
-
- # Parse action arguments, setting a special flag if there were none
- # We otherwise can't tell the difference between arguments that evaluate
- # to the empty set, and the empty set itself.
- set portlist {}
- switch -- [lookahead] {
- ; -
- _EOF_ {
- set private_options(ports_no_args) yes
- }
- default {
- if {[ACTION_ARGS_NONE] == $expand} {
- ui_error "$action does not accept string arguments"
- set action_status 1
- break
- } elseif {[ACTION_ARGS_STRINGS] == $expand} {
- while { [moreargs] && ![match ";"] } {
- lappend portlist [lookahead]
- advance
- }
- } elseif {[ACTION_ARGS_PORTS] == $expand} {
- # Parse port specifications into portlist
- if {![portExpr portlist]} {
- ui_error "Improper expression syntax while processing parameters"
- set action_status 1
- break
- }
- }
- }
- }
-
- # execute the action
- set action_status [$action_proc $action $portlist [array get global_options]]
-
- # unlock if needed
- if {$locked} {
- registry::exclusive_unlock
- }
-
- # Print notifications of just-activated ports.
- portclient::notifications::display
-
- # semaphore to exit
- if {$action_status == -999} break
- }
-
- return $action_status
-}
-
-
-proc complete_portname { text state } {
- global complete_choices complete_position
-
- if {$state == 0} {
- set complete_position 0
- set complete_choices {}
-
- # Build a list of ports with text as their prefix
- if {[catch {set res [mportsearch "${text}*" false glob]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "search for portname $pattern failed: $result"
- }
- foreach {name info} $res {
- lappend complete_choices $name
- }
- }
-
- set word [lindex $complete_choices $complete_position]
- incr complete_position
-
- return $word
-}
-
-
-# return text action beginning with $text
-proc complete_action { text state } {
- global action_array complete_choices complete_position
-
- if {$state == 0} {
- set complete_position 0
- set complete_choices [array names action_array "[string tolower $text]*"]
- }
-
- set word [lindex $complete_choices $complete_position]
- incr complete_position
-
- return $word
-}
-
-# return all actions beginning with $text
-proc guess_action { text } {
- global action_array
-
- return [array names action_array "[string tolower $text]*"]
-
- if { [llength $complete_choices ] == 1 } {
- return [lindex $complete_choices 0]
- }
-
- return {}
-}
-
-proc attempt_completion { text word start end } {
- # If the word starts with '~', or contains '.' or '/', then use the build-in
- # completion to complete the word
- if { [regexp {^~|[/.]} $word] } {
- return ""
- }
-
- # Decide how to do completion based on where we are in the string
- set prefix [string range $text 0 [expr {$start - 1}]]
-
- # If only whitespace characters preceed us, or if the
- # previous non-whitespace character was a ;, then we're
- # an action (the first word of a command)
- if { [regexp {(^\s*$)|(;\s*$)} $prefix] } {
- return complete_action
- }
-
- # Otherwise, do completion on portname
- return complete_portname
-}
-
-
-proc get_next_cmdline { in out use_readline prompt linename } {
- upvar $linename line
-
- set line ""
- while { $line eq "" } {
-
- if {$use_readline} {
- set len [readline read -attempted_completion attempt_completion line $prompt]
- } else {
- puts -nonewline $out $prompt
- flush $out
- set len [gets $in line]
- }
-
- if { $len < 0 } {
- return -1
- }
-
- set line [string trim $line]
-
- if { $use_readline && $line ne "" } {
- rl_history add $line
- }
- }
-
- return [llength $line]
-}
-
-
-proc process_command_file { in } {
- global current_portdir
-
- # Initialize readline
- set isstdin [string match $in "stdin"]
- set name "port"
- set use_readline [expr {$isstdin && [readline init $name]}]
- set history_file [file normalize "${macports::macports_user_dir}/history"]
-
- # Read readline history
- if {$use_readline && [file isdirectory $macports::macports_user_dir]} {
- rl_history read $history_file
- rl_history stifle 100
- }
-
- # Be noisy, if appropriate
- set noisy [expr $isstdin && ![macports::ui_isset ports_quiet]]
- if { $noisy } {
- puts "MacPorts [macports::version]"
- puts "Entering interactive mode... (\"help\" for help, \"quit\" to quit)"
- }
-
- # Main command loop
- set exit_status 0
- while { $exit_status == 0 || $isstdin || [macports::ui_isset ports_processall] } {
-
- # Calculate our prompt
- if { $noisy } {
- set shortdir [eval file join [lrange [file split $current_portdir] end-1 end]]
- set prompt "\[$shortdir\] > "
- } else {
- set prompt ""
- }
-
- # Get a command line
- if { [get_next_cmdline $in stdout $use_readline $prompt line] <= 0 } {
- puts ""
- break
- }
-
- # Process the command
- set exit_status [process_cmd $line]
-
- # Check for semaphore to exit
- if {$exit_status == -999} {
- set exit_status 0
- break
- }
- }
-
- # Create macports user directory if it does not exist yet
- if {$use_readline && ![file isdirectory $macports::macports_user_dir]} {
- file mkdir $macports::macports_user_dir
- }
- # Save readine history
- if {$use_readline && [file isdirectory $macports::macports_user_dir]} {
- rl_history write $history_file
- }
-
- # Say goodbye
- if { $noisy } {
- puts "Goodbye"
- }
-
- return $exit_status
-}
-
-
-proc process_command_files { filelist } {
- set exit_status 0
-
- # For each file in the command list, process commands
- # in the file
- foreach file $filelist {
- if {$file eq "-"} {
- set in stdin
- } else {
- if {[catch {set in [open $file]} result]} {
- fatal "Failed to open command file; $result"
- }
- }
-
- set exit_status [process_command_file $in]
-
- if {$in ne "stdin"} {
- close $in
- }
-
- # Exit on first failure unless -p was given
- if {$exit_status != 0 && ![macports::ui_isset ports_processall]} {
- return $exit_status
- }
- }
-
- return $exit_status
-}
-
-namespace eval portclient::progress {
- ##
- # Maximum width of the progress bar or indicator when displaying it.
- variable maxWidth 50
-
- ##
- # The start time of the last progress callback as returned by [clock time].
- # Since only one progress indicator is active at a time, this variable is
- # shared between the different variants of progress functions.
- variable startTime
-
- ##
- # Delay in milliseconds after the start of the operation before deciding
- # that showing a progress bar makes sense.
- variable showTimeThreshold 500
-
- ##
- # Percentage value between 0 and 1 that must not have been reached yet when
- # $showTimeThreshold has passed for a progress bar to be shown. If the
- # operation has proceeded above e.g. 75% after 500ms we won't bother
- # displaying a progress indicator anymore -- the operation will be finished
- # in well below a second anyway.
- variable showPercentageThreshold 0.75
-
- ##
- # Boolean indication whether the progress indicator should be shown or is
- # still hidden because the current operation didn't need enough time for
- # a progress indicator to make sense, yet.
- variable show no
-
- ##
- # Initialize the progress bar display delay; call this from the start
- # action of the progress functions.
- proc initDelay {} {
- variable show
- variable startTime
-
- set startTime [clock milliseconds]
- set show no
- }
-
- ##
- # Determine whether a progress bar should be shown for the current
- # operation in its current state. You must have called initDelay for the
- # current operation before calling this method.
- #
- # @param cur
- # Current progress in abstract units.
- # @param total
- # Total number of abstract units to be processed, if known. Pass
- # 0 if unknown.
- # @return
- # "yes", if the progress indicator should be shown, "no" otherwise.
- proc showProgress {cur total} {
- variable show
- variable startTime
- variable showTimeThreshold
- variable showPercentageThreshold
-
- if {$show eq "yes"} {
- return yes
- } else {
- if {[expr {[clock milliseconds] - $startTime}] > $showTimeThreshold &&
- ($total == 0 || [expr {double($cur) / double($total)}] < $showPercentageThreshold)} {
- set show yes
- }
- return $show
- }
- }
-
- ##
- # Progress callback for generic operations executed by macports 1.0.
- #
- # @param action
- # One of "start", "update", "intermission" or "finish", where start
- # will be called before any number of update calls, interrupted by
- # any number of intermission calls (called because other output is
- # being produced), followed by one call to finish.
- # @param args
- # A list of variadic args that differ for each action. For "start",
- # "intermission" and "finish", the args are empty and unused. For
- # "update", args contains $cur and $total, where $cur is the current
- # number of units processed and $total is the total number of units
- # to be processed. If the total is not known, it is 0.
- proc generic {action args} {
- global env
- variable maxWidth
-
- switch -nocase -- $action {
- start {
- initDelay
- }
- update {
- # the for loop is a simple hack because Tcl 8.4 doesn't have
- # lassign
- foreach {now total} $args {
- if {[showProgress $now $total] eq "yes"} {
- set barPrefix " "
- set barPrefixLen [string length $barPrefix]
- if {$total != 0} {
- progressbar $now $total [expr {min($maxWidth, $env(COLUMNS) - $barPrefixLen)}] $barPrefix
- } else {
- unprogressbar [expr {min($maxWidth, $env(COLUMNS) - $barPrefixLen)}] $barPrefix
- }
- }
- }
- }
- intermission -
- finish {
- # erase to start of line
- ::term::ansi::send::esol
- # return cursor to start of line
- puts -nonewline "\r"
- flush stdout
- }
- }
-
- return 0
- }
-
- ##
- # Progress callback for downloads executed by macports 1.0.
- #
- # This is essentially a cURL progress callback.
- #
- # @param action
- # One of "start", "update" or "finish", where start will be called
- # before any number of update calls, followed by one call to finish.
- # @param args
- # A list of variadic args that differ for each action. For "start",
- # contains a single argument "ul" or "dl" indicating whether this is
- # an up- or download. For "update", contains the arguments
- # ("ul"|"dl") $total $now $speed where ul/dl are as for start, and
- # total, now and speed are doubles indicating the total transfer
- # size, currently transferred amount and average speed per second in
- # bytes. Unused for "finish".
- proc download {action args} {
- global env
- variable maxWidth
-
- switch -nocase -- $action {
- start {
- initDelay
- }
- update {
- # the for loop is a simple hack because Tcl 8.4 doesn't have
- # lassign
- foreach {type total now speed} $args {
- if {[showProgress $now $total] eq "yes"} {
- set barPrefix " "
- set barPrefixLen [string length $barPrefix]
- if {$total != 0} {
- set barSuffix [format " speed: %-13s" "[bytesize $speed {} "%.1f"]/s"]
- set barSuffixLen [string length $barSuffix]
-
- set barLen [expr {min($maxWidth, $env(COLUMNS) - $barPrefixLen - $barSuffixLen)}]
- progressbar $now $total $barLen $barPrefix $barSuffix
- } else {
- set barSuffix [format " %-10s speed: %-13s" [bytesize $now {} "%6.1f"] "[bytesize $speed {} "%.1f"]/s"]
- set barSuffixLen [string length $barSuffix]
-
- set barLen [expr {min($maxWidth, $env(COLUMNS) - $barPrefixLen - $barSuffixLen)}]
- unprogressbar $barLen $barPrefix $barSuffix
- }
- }
- }
- }
- finish {
- # erase to start of line
- ::term::ansi::send::esol
- # return cursor to start of line
- puts -nonewline "\r"
- flush stdout
- }
- }
-
- return 0
- }
-
- ##
- # Draw a progress bar using unicode block drawing characters
- #
- # @param current
- # The current progress value.
- # @param total
- # The progress value representing 100%.
- # @param width
- # The width in characters of the progress bar. This includes percentage
- # output, which takes up 8 characters.
- # @param prefix
- # Prefix to be printed in front of the progress bar.
- # @param suffix
- # Suffix to be printed after the progress bar.
- proc progressbar {current total width {prefix ""} {suffix ""}} {
- # Subtract the width of the percentage output, also subtract the two
- # characters [ and ] bounding the progress bar.
- set percentageWidth 8
- set barWidth [expr {entier($width) - $percentageWidth - 2}]
-
- # Map the range (0, $total) to (0, 4 * $width) where $width is the maximum
- # numebr of characters to be printed for the progress bar. Multiply the
- # upper bound with 8 because we have 8 sub-states per character.
- set barProgress [expr {entier(round(($current * $barWidth * 8) / $total))}]
-
- set barInteger [expr {$barProgress / 8}]
- #set barRemainder [expr {$barProgress % 8}]
-
- # Finally, also provide a percentage value to print behind the progress bar
- set percentage [expr {double($current) * 100 / double($total)}]
-
- # clear the current line, enable reverse video
- set progressbar "\033\[7m"
- for {set i 0} {$i < $barInteger} {incr i} {
- # U+2588 FULL BLOCK doesn't match the other blocks in some fonts :/
- # Two half blocks work better in some fonts, but not in others (because
- # they leave ugly spaces). So, one or the other choice isn't better or
- # worse and even just using full blocks looks ugly in a few fonts.
-
- # Use pure ASCII until somebody fixes most of the default terminal fonts :/
- append progressbar " "
- }
- # back to normal output
- append progressbar "\033\[0m"
-
- #switch $barRemainder {
- # 0 {
- # if {$barInteger < $barWidth} {
- # append progressbar " "
- # }
- # }
- # 1 {
- # # U+258F LEFT ONE EIGHTH BLOCK
- # append progressbar "\u258f"
- # }
- # 2 {
- # # U+258E LEFT ONE QUARTER BLOCK
- # append progressbar "\u258e"
- # }
- # 3 {
- # # U+258D LEFT THREE EIGHTHS BLOCK
- # append progressbar "\u258d"
- # }
- # 3 {
- # # U+258D LEFT THREE EIGHTHS BLOCK
- # append progressbar "\u258d"
- # }
- # 4 {
- # # U+258C LEFT HALF BLOCK
- # append progressbar "\u258c"
- # }
- # 5 {
- # # U+258B LEFT FIVE EIGHTHS BLOCK
- # append progressbar "\u258b"
- # }
- # 6 {
- # # U+258A LEFT THREE QUARTERS BLOCK
- # append progressbar "\u258a"
- # }
- # 7 {
- # # U+2589 LEFT SEVEN EIGHTHS BLOCK
- # append progressbar "\u2589"
- # }
- #}
-
- # Fill the progress bar with spaces
- for {set i $barInteger} {$i < $barWidth} {incr i} {
- append progressbar " "
- }
-
- # Format the percentage using the space that has been reserved for it
- set percentagesuffix [format " %[expr {$percentageWidth - 3}].1f %%" $percentage]
-
- puts -nonewline "\r${prefix}\[${progressbar}\]${percentagesuffix}${suffix}"
- flush stdout
- }
-
-
- ##
- # Internal state of the progress indicator; unless you're hacking the
- # unprogressbar code you should never touch this.
- variable unprogressState 0
-
- ##
- # Draw a progress indicator
- #
- # @param width
- # The width in characters of the progress indicator.
- # @param prefix
- # Prefix to be printed in front of the progress indicator.
- # @param suffix
- # Suffix to be printed after the progress indicator.
- proc unprogressbar {width {prefix ""} {suffix ""}} {
- variable unprogressState
-
- # Subtract the two characters [ and ] bounding the progress indicator
- # from the width.
- set barWidth [expr {int($width) - 2}]
-
- # Number of states of the progress bar, or rather: the number of
- # characters before the sequence repeats.
- set numStates 4
-
- set unprogressState [expr {($unprogressState + 1) % $numStates}]
-
- set progressbar ""
- for {set i 0} {$i < $barWidth} {incr i} {
- if {[expr {$i % $numStates}] == $unprogressState} {
- # U+2022 BULLET
- append progressbar "\u2022"
- } else {
- append progressbar " "
- }
- }
-
- puts -nonewline "\r${prefix}\[${progressbar}\]${suffix}"
- flush stdout
- }
-}
-
-namespace eval portclient::notifications {
- ##
- # Ports whose notifications to display; these were either installed
- # or requested to be installed.
- variable notificationsToPrint
- array set notificationsToPrint {}
-
- ##
- # Add a port to the list for printing notifications.
- #
- # @param name
- # The name of the port.
- # @param note
- # A list of notes to be stored for the given port.
- proc append {name notes} {
- variable notificationsToPrint
-
- set notificationsToPrint($name) $notes
- }
-
- ##
- # Print port notifications.
- #
- proc display {} {
- global env
- variable notificationsToPrint
-
- # Display notes at the end of the activation phase.
- if {[array size notificationsToPrint] > 0} {
- ui_notice "---> Some of the ports you installed have notes:"
- foreach {name notes} [array get notificationsToPrint] {
- ui_notice " $name has the following notes:"
-
- # If env(COLUMNS) exists, limit each line's width to this width.
- if {[info exists env(COLUMNS)]} {
- set maxlen $env(COLUMNS)
-
- foreach note $notes {
- foreach line [split $note "\n"] {
- set joiner ""
- set lines ""
- set newline " "
-
- foreach word [split $line " "] {
- if {[string length $newline] + [string length $word] >= $maxlen} {
- lappend lines $newline
- set newline " "
- set joiner ""
- }
- ::append newline $joiner $word
- set joiner " "
- }
- if {$newline ne {}} {
- lappend lines $newline
- }
- ui_notice [join $lines "\n"]
- }
- }
- } else {
- foreach note $notes {
- ui_notice $note
- }
- }
- }
- }
- }
-}
-
-
-##########################################
-# Main
-##########################################
-
-# Global arrays passed to the macports1.0 layer
-array set ui_options {}
-array set global_options {}
-array set global_variations {}
-
-# Global options private to this script
-array set private_options {}
-
-# Make sure we get the size of the terminal
-# We do this here to save it in the boot_env, in case we determined it manually
-term_init_size
-
-global env boot_env argv0 cmdname argc argv cmd_argc cmd_argv cmd_argn \
- current_portdir global_options_base exit_status
-
-# Save off a copy of the environment before mportinit monkeys with it
-array set boot_env [array get env]
-
-set cmdname [file tail $argv0]
-
-# Setp cmd_argv to match argv
-set cmd_argv $argv
-set cmd_argc $argc
-set cmd_argn 0
-
-# make sure we're using a sane umask
-umask 022
-
-# If we've been invoked as portf, then the first argument is assumed
-# to be the name of a command file (i.e., there is an implicit -F
-# before any arguments).
-if {[moreargs] && $cmdname eq "portf"} {
- lappend ui_options(ports_commandfiles) [lookahead]
- advance
-}
-
-# Parse global options that will affect all subsequent commands
-if {[catch {parse_options "global" ui_options global_options} result]} {
- puts "Error: $result"
- print_usage
- exit 1
-}
-
-if {[isatty stdout]
- && $portclient::progress::hasTermAnsiSend eq "yes"
- && (![info exists ui_options(ports_quiet)] || $ui_options(ports_quiet) ne "yes")} {
- set ui_options(progress_download) portclient::progress::download
- set ui_options(progress_generic) portclient::progress::generic
-}
-
-set ui_options(notifications_append) portclient::notifications::append
-
-# Get arguments remaining after option processing
-set remaining_args [lrange $cmd_argv $cmd_argn end]
-
-# If we have no arguments remaining after option processing then force
-# interactive mode
-if { [llength $remaining_args] == 0 && ![info exists ui_options(ports_commandfiles)] } {
- lappend ui_options(ports_commandfiles) -
-} elseif {[lookahead] eq "selfupdate" || [lookahead] eq "sync"} {
- # tell mportinit not to tell the user they should selfupdate
- set ui_options(ports_no_old_index_warning) 1
-}
-
-# Initialize mport
-# This must be done following parse of global options, as some options are
-# evaluated by mportinit.
-if {[catch {mportinit ui_options global_options global_variations} result]} {
- global errorInfo
- puts "$errorInfo"
- fatal "Failed to initialize MacPorts, $result"
-}
-
-# Set up some global state for our code
-set current_portdir [pwd]
-
-# Freeze global_options into global_options_base; global_options
-# will be reset to global_options_base prior to processing each command.
-set global_options_base [array get global_options]
-
-# First process any remaining args as action(s)
-set exit_status 0
-if { [llength $remaining_args] > 0 } {
-
- # If there are remaining arguments, process those as a command
- set exit_status [process_cmd $remaining_args]
-}
-
-# Process any prescribed command files, including standard input
-if { ($exit_status == 0 || [macports::ui_isset ports_processall]) && [info exists ui_options(ports_commandfiles)] } {
- set exit_status [process_command_files $ui_options(ports_commandfiles)]
-}
-if {$exit_status == -999} {
- set exit_status 0
-}
-
-# shut down macports1.0
-mportshutdown
-
-# Return with exit_status
-exit $exit_status
Deleted: branches/gsoc14-cleanup/src/port/port.REMOTE.23878
===================================================================
--- branches/gsoc14-cleanup/src/port/port.REMOTE.23878 2014-08-13 22:14:51 UTC (rev 123747)
+++ branches/gsoc14-cleanup/src/port/port.REMOTE.23878 2014-08-13 22:14:53 UTC (rev 123748)
@@ -1,5355 +0,0 @@
-#!/opt/local/libexec/macports/bin/tclsh8.5
-# -*- coding: utf-8; mode: tcl; tab-width: 4; indent-tabs-mode: nil; c-basic-offset: 4 -*- vim:fenc=utf-8:filetype=tcl:et:sw=4:ts=4:sts=4
-# $Id: port.tcl 119177 2014-04-18 22:35:29Z cal at macports.org $
-#
-# Copyright (c) 2004-2014 The MacPorts Project
-# Copyright (c) 2004 Robert Shaw <rshaw at opendarwin.org>
-# Copyright (c) 2002-2003 Apple 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 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.
-
-# Create a namespace for some local variables
-namespace eval portclient::progress {
- ##
- # Indicate whether the term::ansi::send tcllib package is available and was
- # imported. "yes", if the package is available, "no" otherwise.
- variable hasTermAnsiSend no
-}
-
-if {![catch {package require term::ansi::send}]} {
- set portclient::progress::hasTermAnsiSend yes
-}
-
-package require macports
-package require Pextlib 1.0
-
-# Standard procedures
-proc print_usage {{verbose 1}} {
- global cmdname
- set syntax {
- [-bcdfknopqRstuvy] [-D portdir] [-F cmdfile] action [privopts] [actionflags]
- [[portname|pseudo-portname|port-url] [@version] [+-variant]... [option=value]...]...
- }
-
- if {$verbose} {
- puts stderr "Usage: $cmdname$syntax"
- puts stderr "\"$cmdname help\" or \"man 1 port\" for more information."
- } else {
- puts stderr "$cmdname$syntax"
- }
-}
-
-proc print_help {args} {
- global action_array
-
- print_usage 0
-
- # Generate and format the command list from the action_array
- set cmds ""
- set lineLen 0
- foreach cmd [lsort [array names action_array]] {
- if {$lineLen > 65} {
- set cmds "$cmds,\n"
- set lineLen 0
- }
- if {$lineLen == 0} {
- set new "$cmd"
- } else {
- set new ", $cmd"
- }
- incr lineLen [string length $new]
- set cmds "$cmds$new"
- }
-
- set cmdText "Supported actions
-------------------
-$cmds
-"
-
- set text {
-Pseudo-portnames
-----------------
-Pseudo-portnames are words that may be used in place of a portname, and
-which expand to some set of ports. The common pseudo-portnames are:
-all, current, active, inactive, actinact, installed, uninstalled, outdated,
-obsolete, requested, unrequested and leaves.
-These pseudo-portnames expand to the set of ports named.
-
-Pseudo-portnames starting with variants:, variant:, description:, depends:,
-depends_lib:, depends_run:, depends_build:, depends_fetch:, depends_extract:,
-portdir:, homepage:, epoch:, platforms:, platform:, name:, long_description:,
-maintainers:, maintainer:, categories:, category:, version:, revision:, and
-license: each select a set of ports based on a regex search of metadata
-about the ports. In all such cases, a standard regex pattern following
-the colon will be used to select the set of ports to which the
-pseudo-portname expands.
-
-Pseudo-portnames starting with depof:, rdepof:, dependentof:, and rdependentof:
-select ports that are direct or recursive dependencies or dependents of the
-following portname, respectively.
-
-Portnames that contain standard glob characters will be expanded to the
-set of ports matching the glob pattern.
-
-Port expressions
-----------------
-Portnames, port glob patterns, and pseudo-portnames may be logically
-combined using expressions consisting of and, or, not, !, (, and ).
-
-For more information
---------------------
-See man pages: port(1), macports.conf(5), portfile(7), portgroup(7),
-porthier(7), portstyle(7). Also, see http://www.macports.org.
- }
-
- puts "$cmdText$text"
-}
-
-
-# Produce error message and exit
-proc fatal s {
- global argv0
- ui_error "$argv0: $s"
- exit 1
-}
-
-##
-# Helper function to define constants
-#
-# Constants defined with const can simply be accessed in the same way as
-# calling a proc.
-#
-# Example:
-# const FOO 42
-# puts [FOO]
-#
-# @param name variable name
-# @param value constant variable value
-proc const {name args} {
- proc $name {} [list return [expr $args]]
-}
-
-# Format an integer representing bytes using given units
-proc bytesize {siz {unit {}} {format {%.3f}}} {
- if {$unit == {}} {
- if {$siz > 0x40000000} {
- set unit "GiB"
- } elseif {$siz > 0x100000} {
- set unit "MiB"
- } elseif {$siz > 0x400} {
- set unit "KiB"
- } else {
- set unit "B"
- }
- }
- switch -- $unit {
- KiB {
- set siz [expr {$siz / 1024.0}]
- }
- kB {
- set siz [expr {$siz / 1000.0}]
- }
- MiB {
- set siz [expr {$siz / 1048576.0}]
- }
- MB {
- set siz [expr {$siz / 1000000.0}]
- }
- GiB {
- set siz [expr {$siz / 1073741824.0}]
- }
- GB {
- set siz [expr {$siz / 1000000000.0}]
- }
- B { }
- default {
- ui_warn "Unknown file size unit '$unit' specified"
- set unit "B"
- }
- }
- if {[expr {round($siz)}] != $siz} {
- set siz [format $format $siz]
- }
- return "$siz $unit"
-}
-
-proc filesize {fil {unit {}}} {
- set siz {@}
- catch {
- set siz [bytesize [file size $fil] $unit]
- }
- return $siz
-}
-
-# Produce an error message, and exit, unless
-# we're handling errors in a soft fashion, in which
-# case we continue
-proc fatal_softcontinue s {
- if {[macports::global_option_isset ports_force]} {
- ui_error $s
- return -code continue
- } else {
- fatal $s
- }
-}
-
-
-# Produce an error message, and break, unless
-# we're handling errors in a soft fashion, in which
-# case we continue
-proc break_softcontinue { msg status name_status } {
- upvar $name_status status_var
- ui_error $msg
- if {[macports::ui_isset ports_processall]} {
- set status_var 0
- return -code continue
- } else {
- set status_var $status
- return -code break
- }
-}
-
-# show the URL for the ticket reporting instructions
-proc print_tickets_url {args} {
- if {${macports::prefix} ne "/usr/local" && ${macports::prefix} ne "/usr"} {
- ui_error "Follow http://guide.macports.org/#project.tickets to report a bug."
- }
-}
-
-# Form a composite version as is sometimes used for registry functions
-# This function sorts the variants and presents them in a canonical representation
-proc composite_version {version variations {emptyVersionOkay 0}} {
- # Form a composite version out of the version and variations
-
- # Select the variations into positive and negative
- set pos {}
- set neg {}
- foreach { key val } $variations {
- if {$val eq "+"} {
- lappend pos $key
- } elseif {$val eq "-"} {
- lappend neg $key
- }
- }
-
- # If there is no version, we have nothing to do
- set composite_version ""
- if {$version ne "" || $emptyVersionOkay} {
- set pos_str ""
- set neg_str ""
-
- if {[llength $pos]} {
- set pos_str "+[join [lsort -ascii $pos] "+"]"
- }
- if {[llength $neg]} {
- set neg_str "-[join [lsort -ascii $neg] "-"]"
- }
-
- set composite_version "$version$pos_str$neg_str"
- }
-
- return $composite_version
-}
-
-
-proc split_variants {variants} {
- set result {}
- set l [regexp -all -inline -- {([-+])([[:alpha:]_]+[\w\.]*)} $variants]
- foreach { match sign variant } $l {
- lappend result $variant $sign
- }
- return $result
-}
-
-
-##
-# Maps friendly field names to their real name
-# Names which do not need mapping are not changed.
-#
-# @param field friendly name
-# @return real name
-proc map_friendly_field_names { field } {
- switch -- $field {
- variant -
- platform -
- maintainer -
- subport {
- set field "${field}s"
- }
- category {
- set field "categories"
- }
- }
-
- return $field
-}
-
-
-proc registry_installed {portname {portversion ""}} {
- set ilist [registry::installed $portname $portversion]
- if { [llength $ilist] > 1 } {
- # set portname again since the one we were passed may not have had the correct case
- set portname [lindex $ilist 0 0]
- ui_notice "The following versions of $portname are currently installed:"
- foreach i [portlist_sortint $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 -code error "Registry error: Please specify the full version as recorded in the port registry."
- } else {
- return [lindex $ilist 0]
- }
-}
-
-
-proc entry_for_portlist {portentry} {
- global global_options global_variations
-
- # Each portlist entry currently has the following elements in it:
- # url if any
- # name
- # version (version_revision)
- # variants array (variant=>+-)
- # requested_variants array (variant=>+-)
- # options array (key=>value)
- # fullname (name/version_revision+-variants)
-
- array set port $portentry
- if {![info exists port(url)]} { set port(url) "" }
- if {![info exists port(name)]} { set port(name) "" }
- if {![info exists port(version)]} { set port(version) "" }
- if {![info exists port(variants)]} { set port(variants) "" }
- if {![info exists port(requested_variants)]} { set port(requested_variants) "" }
- if {![info exists port(options)]} { set port(options) [array get global_options] }
-
- # If neither portname nor url is specified, then default to the current port
- if { $port(url) eq "" && $port(name) eq "" } {
- set url file://.
- set portname [url_to_portname $url]
- set port(url) $url
- set port(name) $portname
- if {$portname eq ""} {
- ui_error "A default port name could not be supplied."
- }
- }
-
- # Form the fully discriminated portname: portname/version_revison+-variants
- set port(fullname) "$port(name)/[composite_version $port(version) $port(variants)]"
-
- return [array get port]
-}
-
-
-proc add_to_portlist {listname portentry} {
- upvar $listname portlist
-
- # Form portlist entry and add to portlist
- lappend portlist [entry_for_portlist $portentry]
-}
-
-
-proc add_ports_to_portlist {listname ports {overridelist ""}} {
- upvar $listname portlist
-
- array set overrides $overridelist
-
- # Add each entry to the named portlist, overriding any values
- # specified as overrides
- foreach portentry $ports {
- array set port $portentry
- if ([info exists overrides(version)]) { set port(version) $overrides(version) }
- if ([info exists overrides(variants)]) { set port(variants) $overrides(variants) }
- if ([info exists overrides(requested_variants)]) { set port(requested_variants) $overrides(requested_variants) }
- if ([info exists overrides(options)]) { set port(options) $overrides(options) }
- add_to_portlist portlist [array get port]
- }
-}
-
-
-proc url_to_portname { url {quiet 0} } {
- # Save directory and restore the directory, since mportopen changes it
- set savedir [pwd]
- set portname ""
- if {[catch {set ctx [mportopen $url]} result]} {
- if {!$quiet} {
- ui_msg "Can't map the URL '$url' to a port description file (\"${result}\")."
- ui_msg "Please verify that the directory and portfile syntax are correct."
- }
- } else {
- array set portinfo [mportinfo $ctx]
- set portname $portinfo(name)
- mportclose $ctx
- }
- cd $savedir
- return $portname
-}
-
-
-# Supply a default porturl/portname if the portlist is empty
-proc require_portlist { nameportlist {is_upgrade "no"} } {
- global private_options
- upvar $nameportlist portlist
-
- if {[llength $portlist] == 0 && (![info exists private_options(ports_no_args)] || $private_options(ports_no_args) eq "no")} {
- if {${is_upgrade} == "yes"} {
- # $> port upgrade outdated
- # Error: No ports matched the given expression
- # is not very user friendly - if we're in the special case of
- # "upgrade", let's print a message that's a little easier to
- # understand and less alarming.
- ui_msg "Nothing to upgrade."
- return 1
- }
- ui_error "No ports matched the given expression"
- return 1
- }
-
- if {[llength $portlist] == 0} {
- set portlist [get_current_port]
-
- if {[llength $portlist] == 0} {
- # there was no port in current directory
- return 1
- }
- }
-
- return 0
-}
-
-
-# Execute the enclosed block once for every element in the portlist
-# When the block is entered, the following variables will have been set:
-# portspec, porturl, portname, portversion, options, variations, requested_variations
-proc foreachport {portlist block} {
- set savedir [pwd]
- foreach portspec $portlist {
-
- # Set the variables for the block
- uplevel 1 "array unset portspec; array set portspec { $portspec }"
- uplevel 1 {
- set porturl $portspec(url)
- set portname $portspec(name)
- set portversion $portspec(version)
- array unset variations
- array set variations $portspec(variants)
- array unset requested_variations
- array set requested_variations $portspec(requested_variants)
- array unset options
- array set options $portspec(options)
- }
-
- # Invoke block
- uplevel 1 $block
-
- # Restore cwd after each port, since mportopen changes it, and otherwise relative
- # urls would break on subsequent passes
- if {[file exists $savedir]} {
- cd $savedir
- } else {
- cd ~
- }
- }
-}
-
-
-proc portlist_compare { a b } {
- array set a_ $a
- array set b_ $b
- set namecmp [string equal -nocase $a_(name) $b_(name)]
- if {$namecmp != 1} {
- if {$a_(name) eq [lindex [lsort -dictionary [list $a_(name) $b_(name)]] 0]} {
- return -1
- }
- return 1
- }
- set avr_ [split $a_(version) "_"]
- set bvr_ [split $b_(version) "_"]
- set versioncmp [vercmp [lindex $avr_ 0] [lindex $bvr_ 0]]
- if {$versioncmp != 0} {
- return $versioncmp
- }
- set ar_ [lindex $avr_ 1]
- set br_ [lindex $bvr_ 1]
- if {$ar_ < $br_} {
- return -1
- } elseif {$ar_ > $br_} {
- return 1
- } else {
- return 0
- }
-}
-
-# Sort two ports in NVR (name at version_revision) order
-proc portlist_sort { list } {
- return [lsort -command portlist_compare $list]
-}
-
-proc portlist_compareint { a b } {
- array set a_ [list "name" [lindex $a 0] "version" "[lindex $a 1]_[lindex $a 2]"]
- array set b_ [list "name" [lindex $b 0] "version" "[lindex $b 1]_[lindex $b 2]"]
- return [portlist_compare [array get a_] [array get b_]]
-}
-
-# Same as portlist_sort, but with numeric indexes {name version revision}
-proc portlist_sortint { list } {
- return [lsort -command portlist_compareint $list]
-}
-
-# sort portlist so dependents come before their dependencies
-proc portlist_sortdependents { portlist } {
- foreach p $portlist {
- array set pvals $p
- lappend entries($pvals(name)) $p
- if {![info exists dependents($pvals(name))]} {
- set dependents($pvals(name)) {}
- foreach result [registry::list_dependents $pvals(name)] {
- lappend dependents($pvals(name)) [lindex $result 2]
- }
- }
- array unset pvals
- }
- set ret {}
- foreach p $portlist {
- portlist_sortdependents_helper $p entries dependents seen ret
- }
- return $ret
-}
-
-proc portlist_sortdependents_helper {p up_entries up_dependents up_seen up_retlist} {
- upvar $up_seen seen
- if {![info exists seen($p)]} {
- set seen($p) 1
- upvar $up_entries entries $up_dependents dependents $up_retlist retlist
- array set pvals $p
- foreach dependent $dependents($pvals(name)) {
- if {[info exists entries($dependent)]} {
- foreach entry $entries($dependent) {
- portlist_sortdependents_helper $entry entries dependents seen retlist
- }
- }
- }
- lappend retlist $p
- }
-}
-
-proc regex_pat_sanitize { s } {
- set sanitized [regsub -all {[\\(){}+$.^]} $s {\\&}]
- return $sanitized
-}
-
-##
-# Makes sure we get the current terminal size
-proc term_init_size {} {
- global env
-
- if {![info exists env(COLUMNS)] || ![info exists env(LINES)]} {
- if {[isatty stdout]} {
- set size [term_get_size stdout]
-
- if {![info exists env(LINES)] && [lindex $size 0] > 0} {
- set env(LINES) [lindex $size 0]
- }
-
- if {![info exists env(COLUMNS)] && [lindex $size 1] > 0} {
- set env(COLUMNS) [lindex $size 1]
- }
- }
- }
-}
-
-##
-# Wraps a multi-line string at specified textwidth
-#
-# @see wrapline
-#
-# @param string input string
-# @param maxlen text width (0 defaults to current terminal width)
-# @param indent prepend to every line
-# @return wrapped string
-proc wrap {string maxlen {indent ""} {indentfirstline 1}} {
- global env
-
- if {$maxlen == 0} {
- if {![info exists env(COLUMNS)]} {
- # no width for wrapping
- return $string
- }
- set maxlen $env(COLUMNS)
- }
-
- set splitstring {}
- set indentline $indentfirstline
- foreach line [split $string "\n"] {
- lappend splitstring [wrapline $line $maxlen $indent $indentline]
- set indentline 1
- }
- return [join $splitstring "\n"]
-}
-
-##
-# Wraps a line at specified textwidth
-#
-# @see wrap
-#
-# @param line input line
-# @param maxlen text width (0 defaults to current terminal width)
-# @param indent prepend to every line
-# @return wrapped string
-proc wrapline {line maxlen {indent ""} {indentfirstline 1}} {
- global env
-
- if {$maxlen == 0} {
- if {![info exists env(COLUMNS)]} {
- # no width for wrapping
- return $string
- }
- set maxlen $env(COLUMNS)
- }
-
- set string [split $line " "]
- if {$indentfirstline == 0} {
- set newline ""
- set maxlen [expr {$maxlen - [string length $indent]}]
- } else {
- set newline $indent
- }
- append newline [lindex $string 0]
- set joiner " "
- set first 1
- foreach word [lrange $string 1 end] {
- if {[string length $newline]+[string length $word] >= $maxlen} {
- lappend lines $newline
- set newline $indent
- set joiner ""
- # If indentfirstline is set to 0, reset maxlen to its
- # original length after appending the first line to lines.
- if {$first == 1 && $indentfirstline == 0} {
- set maxlen [expr {$maxlen + [string length $indent]}]
- }
- set first 0
- }
- append newline $joiner $word
- set joiner " "
- }
- lappend lines $newline
- return [join $lines "\n"]
-}
-
-##
-# Wraps a line at a specified width with a label in front
-#
-# @see wrap
-#
-# @param label label for output
-# @param string input string
-# @param maxlen text width (0 defaults to current terminal width)
-# @return wrapped string
-proc wraplabel {label string maxlen {indent ""}} {
- append label ": [string repeat " " [expr {[string length $indent] - [string length "$label: "]}]]"
- return "$label[wrap $string $maxlen $indent 0]"
-}
-
-proc unobscure_maintainers { list } {
- set result {}
- foreach m $list {
- if {[string first "@" $m] < 0} {
- if {[string first ":" $m] >= 0} {
- set m [regsub -- "(.*):(.*)" $m "\\2@\\1"]
- } else {
- set m "$m at macports.org"
- }
- }
- lappend result $m
- }
- return $result
-}
-
-
-##########################################
-# Port selection
-##########################################
-proc unique_results_to_portlist {infos} {
- set result {}
- array unset unique
- foreach {name info} $infos {
- array unset portinfo
- array set portinfo $info
-
- set portentry [entry_for_portlist [list url $portinfo(porturl) name $name]]
-
- array unset entry
- array set entry $portentry
-
- if {[info exists unique($entry(fullname))]} continue
- set unique($entry(fullname)) 1
-
- lappend result $portentry
- }
- return $result
-}
-
-
-proc get_matching_ports {pattern {casesensitive no} {matchstyle glob} {field name}} {
- if {[catch {set res [mportsearch $pattern $casesensitive $matchstyle $field]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "search for portname $pattern failed: $result"
- }
- set results [unique_results_to_portlist $res]
-
- # Return the list of all ports, sorted
- return [portlist_sort $results]
-}
-
-
-proc get_all_ports {} {
- global all_ports_cache
-
- if {![info exists all_ports_cache]} {
- if {[catch {set res [mportlistall]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "listing all ports failed: $result"
- }
- set results [unique_results_to_portlist $res]
- set all_ports_cache [portlist_sort $results]
- }
- return $all_ports_cache
-}
-
-
-proc get_current_ports {} {
- # This is just a synonym for get_current_port that
- # works with the regex in element
- return [get_current_port]
-}
-
-
-proc get_current_port {} {
- set url file://.
- set portname [url_to_portname $url]
- if {$portname eq ""} {
- ui_msg "To use the current port, you must be in a port's directory."
- return [list]
- }
-
- set results {}
- add_to_portlist results [list url $url name $portname]
- return $results
-}
-
-
-proc get_installed_ports { {ignore_active yes} {active yes} } {
- set ilist {}
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "port installed failed: $result"
- }
- }
-
- set results {}
- foreach i $ilist {
- set iname [lindex $i 0]
- set iversion [lindex $i 1]
- set irevision [lindex $i 2]
- set ivariants [split_variants [lindex $i 3]]
- set iactive [lindex $i 4]
-
- if { ${ignore_active} == "yes" || (${active} == "yes") == (${iactive} != 0) } {
- add_to_portlist results [list name $iname version "${iversion}_${irevision}" variants $ivariants]
- }
- }
-
- # Return the list of ports, sorted
- return [portlist_sort $results]
-}
-
-
-proc get_uninstalled_ports {} {
- # Return all - installed
- set all [get_all_ports]
- set installed [get_installed_ports]
- return [opComplement $all $installed]
-}
-
-
-proc get_active_ports {} {
- return [get_installed_ports no yes]
-}
-
-
-proc get_inactive_ports {} {
- return [get_installed_ports no no]
-}
-
-proc get_actinact_ports {} {
- set inactive_ports [get_inactive_ports]
- set active_ports [get_active_ports]
- set results {}
-
- foreach port $inactive_ports {
- array set portspec $port
- set portname $portspec(name)
- lappend inact($portname) $port
- }
-
- foreach port $active_ports {
- array set portspec $port
- set portname $portspec(name)
-
- if {[info exists inact($portname)]} {
- if {![info exists added_inact($portname)]} {
- foreach inact_spec $inact($portname) {
- lappend results $inact_spec
- }
- set added_inact($portname) 1
- }
- lappend results $port
- }
- }
- return $results
-}
-
-
-proc get_outdated_ports {} {
- # Get the list of installed ports
- set ilist {}
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "port installed failed: $result"
- }
- }
-
- # Now process the list, keeping only those ports that are outdated
- set results {}
- if { [llength $ilist] > 0 } {
- foreach i $ilist {
-
- # Get information about the installed port
- set portname [lindex $i 0]
- set installed_version [lindex $i 1]
- set installed_revision [lindex $i 2]
- set installed_compound "${installed_version}_${installed_revision}"
- set installed_variants [lindex $i 3]
-
- set is_active [lindex $i 4]
- if {$is_active == 0} continue
-
- set installed_epoch [lindex $i 5]
-
- # Get info about the port from the index
- if {[catch {set res [mportlookup $portname]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "lookup of portname $portname failed: $result"
- }
- if {[llength $res] < 2} {
- if {[macports::ui_isset ports_debug]} {
- puts stderr "$portname ($installed_compound is installed; the port was not found in the port index)"
- }
- continue
- }
- array unset portinfo
- array set portinfo [lindex $res 1]
-
- # Get information about latest available version and revision
- set latest_version $portinfo(version)
- set latest_revision 0
- if {[info exists portinfo(revision)] && $portinfo(revision) > 0} {
- set latest_revision $portinfo(revision)
- }
- set latest_compound "${latest_version}_${latest_revision}"
- set latest_epoch 0
- if {[info exists portinfo(epoch)]} {
- set latest_epoch $portinfo(epoch)
- }
-
- # Compare versions, first checking epoch, then version, then revision
- set comp_result 0
- if {$installed_version != $latest_version} {
- set comp_result [expr {$installed_epoch - $latest_epoch}]
- if { $comp_result == 0 } {
- set comp_result [vercmp $installed_version $latest_version]
- }
- }
- if { $comp_result == 0 } {
- set comp_result [expr {$installed_revision - $latest_revision}]
- }
- if {$comp_result == 0} {
- set regref [registry::open_entry $portname $installed_version $installed_revision $installed_variants $installed_epoch]
- set os_platform_installed [registry::property_retrieve $regref os_platform]
- set os_major_installed [registry::property_retrieve $regref os_major]
- if {$os_platform_installed ne "" && $os_platform_installed != 0
- && $os_major_installed ne "" && $os_major_installed != 0
- && ($os_platform_installed != ${macports::os_platform} || $os_major_installed != ${macports::os_major})} {
- set comp_result -1
- }
- }
-
- # Add outdated ports to our results list
- if { $comp_result < 0 } {
- add_to_portlist results [list name $portname version $installed_compound variants [split_variants $installed_variants]]
- }
- }
- }
-
- return [portlist_sort $results]
-}
-
-
-proc get_obsolete_ports {} {
- set ilist [get_installed_ports]
- set results {}
-
- foreach i $ilist {
- array set port $i
-
- if {[catch {mportlookup $port(name)} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
-
- if {[llength $result] < 2} {
- lappend results $i
- }
- }
-
- # Return the list of ports, already sorted
- return [portlist_sort $results]
-}
-
-# return ports that have registry property $propname set to $propval
-proc get_ports_with_prop {propname propval} {
- set ilist {}
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "port installed failed: $result"
- }
- }
-
- set results {}
- foreach i $ilist {
- set iname [lindex $i 0]
- set iversion [lindex $i 1]
- set irevision [lindex $i 2]
- set ivariants [lindex $i 3]
- set iepoch [lindex $i 5]
- set regref [registry::open_entry $iname $iversion $irevision $ivariants $iepoch]
- if {[registry::property_retrieve $regref $propname] == $propval} {
- add_to_portlist results [list name $iname version "${iversion}_${irevision}" variants [split_variants $ivariants]]
- }
- }
-
- # Return the list of ports, sorted
- return [portlist_sort $results]
-}
-
-proc get_requested_ports {} {
- return [get_ports_with_prop requested 1]
-}
-
-proc get_unrequested_ports {} {
- return [get_ports_with_prop requested 0]
-}
-
-proc get_leaves_ports {} {
- set ilist {}
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "port installed failed: $result"
- }
- }
- registry::open_dep_map
- set results {}
- foreach i $ilist {
- set iname [lindex $i 0]
- if {[registry::list_dependents $iname] eq ""} {
- add_to_portlist results [list name $iname version "[lindex $i 1]_[lindex $i 2]" variants [split_variants [lindex $i 3]]]
- }
- }
- return [portlist_sort [opIntersection $results [get_unrequested_ports]]]
-}
-
-proc get_dependent_ports {portname recursive} {
- registry::open_dep_map
- set deplist [registry::list_dependents $portname]
- # could return specific versions here using registry2.0 features
- set results {}
- foreach dep $deplist {
- add_to_portlist results [list name [lindex $dep 2]]
- }
-
- # actually do this iteratively to avoid hitting Tcl's recursion limit
- if {$recursive} {
- while 1 {
- set rportlist {}
- set newlist {}
- foreach dep $deplist {
- set depname [lindex $dep 2]
- if {![info exists seen($depname)]} {
- set seen($depname) 1
- set rdeplist [registry::list_dependents $depname]
- foreach rdep $rdeplist {
- lappend newlist $rdep
- add_to_portlist rportlist [list name [lindex $rdep 2]]
- }
- }
- }
- if {[llength $rportlist] > 0} {
- set results [opUnion $results $rportlist]
- set deplist $newlist
- } else {
- break
- }
- }
- }
-
- return [portlist_sort $results]
-}
-
-
-proc get_dep_ports {portname recursive} {
- global global_variations
-
- # look up portname
- if {[catch {mportlookup $portname} result]} {
- ui_debug "$::errorInfo"
- return -code error "lookup of portname $portname failed: $result"
- }
- if {[llength $result] < 2} {
- return -code error "Port $portname not found"
- }
- array unset portinfo
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
-
- # open portfile
- if {[catch {set mport [mportopen $porturl [list subport $portinfo(name)] [array get global_variations]]} result]} {
- ui_debug "$::errorInfo"
- return -code error "Unable to open port: $result"
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
-
- # gather its deps
- set results {}
- set deptypes {depends_fetch depends_extract depends_build depends_lib depends_run}
-
- set deplist {}
- foreach type $deptypes {
- if {[info exists portinfo($type)]} {
- foreach dep $portinfo($type) {
- add_to_portlist results [list name [lindex [split $dep :] end]]
- lappend deplist $dep
- }
- }
- }
-
- # actually do this iteratively to avoid hitting Tcl's recursion limit
- if {$recursive} {
- while 1 {
- set rportlist {}
- set newlist {}
- foreach dep $deplist {
- set depname [lindex [split $dep :] end]
- if {![info exists seen($depname)]} {
- set seen($depname) 1
-
- # look up the dep
- if {[catch {mportlookup $depname} result]} {
- ui_debug "$::errorInfo"
- return -code error "lookup of portname $depname failed: $result"
- }
- if {[llength $result] < 2} {
- ui_error "Port $depname not found"
- continue
- }
- array unset portinfo
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
-
- # open its portfile
- if {[catch {set mport [mportopen $porturl [list subport $portinfo(name)] [array get global_variations]]} result]} {
- ui_debug "$::errorInfo"
- ui_error "Unable to open port: $result"
- continue
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
-
- # collect its deps
- set rdeplist {}
- foreach type $deptypes {
- if {[info exists portinfo($type)]} {
- foreach rdep $portinfo($type) {
- add_to_portlist results [list name [lindex [split $rdep :] end]]
- lappend rdeplist $rdep
- }
- }
- }
-
- # add them to the lists
- foreach rdep $rdeplist {
- lappend newlist $rdep
- add_to_portlist rportlist [list name [lindex [split $rdep :] end]]
- }
- }
- }
- if {[llength $rportlist] > 0} {
- set results [opUnion $results $rportlist]
- set deplist $newlist
- } else {
- break
- }
- }
- }
-
- return [portlist_sort $results]
-}
-
-proc get_subports {portname} {
- global global_variations
-
- # look up portname
- if {[catch {mportlookup $portname} result]} {
- ui_debug "$::errorInfo"
- return -code error "lookup of portname $portname failed: $result"
- }
- if {[llength $result] < 2} {
- return -code error "Port $portname not found"
- }
- array unset portinfo
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
-
- # open portfile
- if {[catch {set mport [mportopen $porturl [list subport $portinfo(name)] [array get global_variations]]} result]} {
- ui_debug "$::errorInfo"
- return -code error "Unable to open port: $result"
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
-
- # gather its subports
- set results {}
-
- if {[info exists portinfo(subports)]} {
- foreach subport $portinfo(subports) {
- add_to_portlist results [list name $subport]
- }
- }
-
- return [portlist_sort $results]
-}
-
-
-##########################################
-# Port expressions
-##########################################
-proc portExpr { resname } {
- upvar $resname reslist
- set result [seqExpr reslist]
- return $result
-}
-
-
-proc seqExpr { resname } {
- upvar $resname reslist
-
- # Evaluate a sequence of expressions a b c...
- # These act the same as a or b or c
-
- set result 1
- while {$result} {
- switch -- [lookahead] {
- ; -
- ) -
- _EOF_ { break }
- }
-
- set blist {}
- set result [orExpr blist]
- if {$result} {
- # Calculate the union of result and b
- set reslist [opUnion $reslist $blist]
- }
- }
-
- return $result
-}
-
-
-proc orExpr { resname } {
- upvar $resname reslist
-
- set a [andExpr reslist]
- while ($a) {
- switch -- [lookahead] {
- or {
- advance
- set blist {}
- if {![andExpr blist]} {
- return 0
- }
-
- # Calculate a union b
- set reslist [opUnion $reslist $blist]
- }
- default {
- return $a
- }
- }
- }
-
- return $a
-}
-
-
-proc andExpr { resname } {
- upvar $resname reslist
-
- set a [unaryExpr reslist]
- while {$a} {
- switch -- [lookahead] {
- and {
- advance
-
- set blist {}
- set b [unaryExpr blist]
- if {!$b} {
- return 0
- }
-
- # Calculate a intersect b
- set reslist [opIntersection $reslist $blist]
- }
- default {
- return $a
- }
- }
- }
-
- return $a
-}
-
-
-proc unaryExpr { resname } {
- upvar $resname reslist
- set result 0
-
- switch -- [lookahead] {
- ! -
- not {
- advance
- set blist {}
- set result [unaryExpr blist]
- if {$result} {
- set all [get_all_ports]
- set reslist [opComplement $all $blist]
- }
- }
- default {
- set result [element reslist]
- }
- }
-
- return $result
-}
-
-
-proc element { resname } {
- upvar $resname reslist
- set el 0
-
- set url ""
- set name ""
- set version ""
- array unset requested_variants
- array unset options
-
- set token [lookahead]
- switch -regex -- $token {
- ^\\)$ -
- ^\; -
- ^_EOF_$ { # End of expression/cmd/file
- }
-
- ^\\($ { # Parenthesized Expression
- advance
- set el [portExpr reslist]
- if {!$el || ![match ")"]} {
- set el 0
- }
- }
-
- ^all(@.*)?$ -
- ^installed(@.*)?$ -
- ^uninstalled(@.*)?$ -
- ^active(@.*)?$ -
- ^inactive(@.*)?$ -
- ^actinact(@.*)?$ -
- ^leaves(@.*)?$ -
- ^outdated(@.*)?$ -
- ^obsolete(@.*)?$ -
- ^requested(@.*)?$ -
- ^unrequested(@.*)?$ -
- ^current(@.*)?$ {
- # A simple pseudo-port name
- advance
-
- # Break off the version component, if there is one
- regexp {^(\w+)(@.*)?} $token matchvar name remainder
-
- add_multiple_ports reslist [get_${name}_ports] $remainder
-
- set el 1
- }
-
- ^variants: -
- ^variant: -
- ^description: -
- ^portdir: -
- ^homepage: -
- ^epoch: -
- ^platforms: -
- ^platform: -
- ^name: -
- ^long_description: -
- ^maintainers: -
- ^maintainer: -
- ^categories: -
- ^category: -
- ^version: -
- ^depends_lib: -
- ^depends_build: -
- ^depends_run: -
- ^depends_extract: -
- ^depends_fetch: -
- ^replaced_by: -
- ^revision: -
- ^subport: -
- ^subports: -
- ^license: { # Handle special port selectors
- advance
-
- # Break up the token, because older Tcl switch doesn't support -matchvar
- regexp {^(\w+):(.*)} $token matchvar field pat
-
- # Remap friendly names to actual names
- set field [map_friendly_field_names $field]
-
- add_multiple_ports reslist [get_matching_ports $pat no regexp $field]
- set el 1
- }
-
- ^depends: { # A port selector shorthand for depends_{lib,build,run,fetch,extract}
- advance
-
- # Break up the token, because older Tcl switch doesn't support -matchvar
- regexp {^(\w+):(.*)} $token matchvar field pat
-
- add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_lib"]
- add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_build"]
- add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_run"]
- add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_extract"]
- add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_fetch"]
-
- set el 1
- }
-
- ^dependentof: -
- ^rdependentof: {
- advance
-
- # Break up the token, because older Tcl switch doesn't support -matchvar
- regexp {^(\w+):(.*)} $token matchvar selector portname
-
- set recursive [string equal $selector "rdependentof"]
- add_multiple_ports reslist [get_dependent_ports $portname $recursive]
-
- set el 1
- }
-
- ^depof: -
- ^rdepof: {
- advance
-
- # Break up the token, because older Tcl switch doesn't support -matchvar
- regexp {^(\w+):(.*)} $token matchvar selector portname
-
- set recursive [string equal $selector "rdepof"]
- add_multiple_ports reslist [get_dep_ports $portname $recursive]
-
- set el 1
- }
-
- ^subportof: {
- advance
-
- # Break up the token, because older Tcl switch doesn't support -matchvar
- regexp {^(\w+):(.*)} $token matchvar selector portname
-
- add_multiple_ports reslist [get_subports $portname]
-
- set el 1
- }
-
- [][?*] { # Handle portname glob patterns
- advance; add_multiple_ports reslist [get_matching_ports $token no glob]
- set el 1
- }
-
- ^\\w+:.+ { # Handle a url by trying to open it as a port and mapping the name
- advance
- set name [url_to_portname $token]
- if {$name ne ""} {
- parsePortSpec version requested_variants options
- add_to_portlist reslist [list url $token \
- name $name \
- version $version \
- requested_variants [array get requested_variants] \
- variants [array get requested_variants] \
- options [array get options]]
- set el 1
- } else {
- ui_error "Can't open URL '$token' as a port"
- set el 0
- }
- }
-
- default { # Treat anything else as a portspec (portname, version, variants, options
- # or some combination thereof).
- parseFullPortSpec url name version requested_variants options
- add_to_portlist reslist [list url $url \
- name $name \
- version $version \
- requested_variants [array get requested_variants] \
- variants [array get requested_variants] \
- options [array get options]]
- set el 1
- }
- }
-
- return $el
-}
-
-
-proc add_multiple_ports { resname ports {remainder ""} } {
- upvar $resname reslist
-
- set version ""
- array unset variants
- array unset options
- parsePortSpec version variants options $remainder
-
- array unset overrides
- if {$version ne ""} { set overrides(version) $version }
- if {[array size variants]} {
- # we always record the requested variants separately,
- # but requested ones always override existing ones
- set overrides(requested_variants) [array get variants]
- set overrides(variants) [array get variants]
- }
- if {[array size options]} { set overrides(options) [array get options] }
-
- add_ports_to_portlist reslist $ports [array get overrides]
-}
-
-
-proc unique_entries { entries } {
- # Form the list of all the unique elements in the list a,
- # considering only the port fullname, and taking the first
- # found element first
- set result {}
- array unset unique
- foreach item $entries {
- array set port $item
- if {[info exists unique($port(fullname))]} continue
- set unique($port(fullname)) 1
- lappend result $item
- }
- return $result
-}
-
-
-proc opUnion { a b } {
- # Return the unique elements in the combined two lists
- return [unique_entries [concat $a $b]]
-}
-
-
-proc opIntersection { a b } {
- set result {}
-
- # Rules we follow in performing the intersection of two port lists:
- #
- # a/, a/ ==> a/
- # a/, b/ ==>
- # a/, a/1.0 ==> a/1.0
- # a/1.0, a/ ==> a/1.0
- # a/1.0, a/2.0 ==>
- #
- # If there's an exact match, we take it.
- # If there's a match between simple and discriminated, we take the later.
-
- # First create a list of the fully discriminated names in b
- array unset bfull
- set i 0
- foreach bitem [unique_entries $b] {
- array set port $bitem
- set bfull($port(fullname)) $i
- incr i
- }
-
- # Walk through each item in a, matching against b
- foreach aitem [unique_entries $a] {
- array set port $aitem
-
- # Quote the fullname and portname to avoid special characters messing up the regexp
- set safefullname [regex_pat_sanitize $port(fullname)]
-
- set simpleform [expr { "$port(name)/" == $port(fullname) }]
- if {$simpleform} {
- set pat "^${safefullname}"
- } else {
- set safename [regex_pat_sanitize $port(name)]
- set pat "^${safefullname}$|^${safename}/$"
- }
-
- set matches [array names bfull -regexp $pat]
- foreach match $matches {
- if {$simpleform} {
- set i $bfull($match)
- lappend result [lindex $b $i]
- } else {
- lappend result $aitem
- }
- }
- }
-
- return $result
-}
-
-
-proc opComplement { a b } {
- set result {}
-
- # Return all elements of a not matching elements in b
-
- # First create a list of the fully discriminated names in b
- array unset bfull
- set i 0
- foreach bitem $b {
- array set port $bitem
- set bfull($port(fullname)) $i
- incr i
- }
-
- # Walk through each item in a, taking all those items that don't match b
- foreach aitem $a {
- array set port $aitem
-
- # Quote the fullname and portname to avoid special characters messing up the regexp
- set safefullname [regex_pat_sanitize $port(fullname)]
-
- set simpleform [expr { "$port(name)/" == $port(fullname) }]
- if {$simpleform} {
- set pat "^${safefullname}"
- } else {
- set safename [regex_pat_sanitize $port(name)]
- set pat "^${safefullname}$|^${safename}/$"
- }
-
- set matches [array names bfull -regexp $pat]
-
- # We copy this element to result only if it didn't match against b
- if {![llength $matches]} {
- lappend result $aitem
- }
- }
-
- return $result
-}
-
-
-proc parseFullPortSpec { urlname namename vername varname optname } {
- upvar $urlname porturl
- upvar $namename portname
- upvar $vername portversion
- upvar $varname portvariants
- upvar $optname portoptions
-
- set portname ""
- set portversion ""
- array unset portvariants
- array unset portoptions
-
- if { [moreargs] } {
- # Look first for a potential portname
- #
- # We need to allow a wide variety of tokens here, because of actions like "provides"
- # so we take a rather lenient view of what a "portname" is. We allow
- # anything that doesn't look like either a version, a variant, or an option
- set token [lookahead]
-
- set remainder ""
- if {|[[:alpha:]_]+[\w\.]*=)} $token match]} {
- advance
- regexp {^([^@]+)(@.*)?} $token match portname remainder
-
- # If the portname contains a /, then try to use it as a URL
- if {[string match "*/*" $portname]} {
- set url "file://$portname"
- set name [url_to_portname $url 1]
- if { $name ne "" } {
- # We mapped the url to valid port
- set porturl $url
- set portname $name
- # Continue to parse rest of portspec....
- } else {
- # We didn't map the url to a port; treat it
- # as a raw string for something like port contents
- # or cd
- set porturl ""
- # Since this isn't a port, we don't try to parse
- # any remaining portspec....
- return
- }
- }
- }
-
- # Now parse the rest of the spec
- parsePortSpec portversion portvariants portoptions $remainder
- }
-}
-
-# check if the install prefix is writable
-# should be called by actions that will modify it
-proc prefix_unwritable {} {
- global macports::portdbpath
- if {[file writable $portdbpath]} {
- return 0
- } else {
- ui_error "Insufficient privileges to write to MacPorts install prefix."
- return 1
- }
-}
-
-
-proc parsePortSpec { vername varname optname {remainder ""} } {
- upvar $vername portversion
- upvar $varname portvariants
- upvar $optname portoptions
-
- global global_options
-
- set portversion ""
- array unset portoptions
- array set portoptions [array get global_options]
- array unset portvariants
-
- # Parse port version/variants/options
- set opt $remainder
- set adv 0
- set consumed 0
- for {set firstTime 1} {$opt ne "" || [moreargs]} {set firstTime 0} {
-
- # Refresh opt as needed
- if {$opt eq ""} {
- if {$adv} advance
- set opt [lookahead]
- set adv 1
- set consumed 0
- }
-
- # Version must be first, if it's there at all
- if {$firstTime && [string match {@*} $opt]} {
- # Parse the version
-
- # Strip the @
- set opt [string range $opt 1 end]
-
- # Handle the version
- set sepPos [string first "/" $opt]
- if {$sepPos >= 0} {
- # Version terminated by "/" to disambiguate -variant from part of version
- set portversion [string range $opt 0 [expr {$sepPos - 1}]]
- set opt [string range $opt [expr {$sepPos + 1}] end]
- } else {
- # Version terminated by "+", or else is complete
- set sepPos [string first "+" $opt]
- if {$sepPos >= 0} {
- # Version terminated by "+"
- set portversion [string range $opt 0 [expr {$sepPos - 1}]]
- set opt [string range $opt $sepPos end]
- } else {
- # Unterminated version
- set portversion $opt
- set opt ""
- }
- }
- set consumed 1
- } else {
- # Parse all other options
-
- # Look first for a variable setting: VARNAME=VALUE
- if {[regexp {^([[:alpha:]_]+[\w\.]*)=(.*)} $opt match key val] == 1} {
- # It's a variable setting
- set portoptions($key) "\"$val\""
- set opt ""
- set consumed 1
- } elseif {[regexp {^([-+])([[:alpha:]_]+[\w\.]*)} $opt match sign variant] == 1} {
- # It's a variant
- set portvariants($variant) $sign
- set opt [string range $opt [expr {[string length $variant] + 1}] end]
- set consumed 1
- } else {
- # Not an option we recognize, so break from port option processing
- if { $consumed && $adv } advance
- break
- }
- }
- }
-}
-
-
-##########################################
-# Action Handlers
-##########################################
-
-proc action_get_usage { action } {
- global action_array cmd_opts_array
-
- if {[info exists action_array($action)]} {
- set cmds ""
- if {[info exists cmd_opts_array($action)]} {
- foreach opt $cmd_opts_array($action) {
- if {[llength $opt] == 1} {
- set name $opt
- set optc 0
- } else {
- set name [lindex $opt 0]
- set optc [lindex $opt 1]
- }
-
- append cmds " --$name"
-
- for {set i 1} {$i <= $optc} {incr i} {
- append cmds " <arg$i>"
- }
- }
- }
- set args ""
- set needed [action_needs_portlist $action]
- if {[ACTION_ARGS_STRINGS] == $needed} {
- set args " <arguments>"
- } elseif {[ACTION_ARGS_STRINGS] == $needed} {
- set args " <portlist>"
- }
-
- set ret "Usage: "
- set len [string length $action]
- append ret [wrap "$action$cmds$args" 0 [string repeat " " [expr {8 + $len}]] 0]
- append ret "\n"
-
- return $ret
- }
-
- return -1
-}
-
-proc action_usage { action portlist opts } {
- if {[llength $portlist] == 0} {
- print_usage
- return 0
- }
-
- foreach topic $portlist {
- set usage [action_get_usage $topic]
- if {$usage != -1} {
- puts -nonewline stderr $usage
- } else {
- ui_error "No usage for topic $topic"
- return 1
- }
- }
- return 0
-}
-
-
-proc action_help { action portlist opts } {
- set helpfile "$macports::prefix/var/macports/port-help.tcl"
-
- if {[llength $portlist] == 0} {
- print_help
- return 0
- }
-
- if {[file exists $helpfile]} {
- if {[catch {source $helpfile} err]} {
- puts stderr "Error reading helpfile $helpfile: $err"
- return 1
- }
- } else {
- puts stderr "Unable to open help file $helpfile"
- return 1
- }
-
- foreach topic $portlist {
- if {![info exists porthelp($topic)]} {
- puts stderr "No help for topic $topic"
- return 1
- }
-
- set usage [action_get_usage $topic]
- if {$usage != -1} {
- puts -nonewline stderr $usage
- } else {
- ui_error "No usage for topic $topic"
- return 1
- }
-
- puts stderr $porthelp($topic)
- }
-
- return 0
-}
-
-
-proc action_log { action portlist opts } {
- global global_options
- if {[require_portlist portlist]} {
- return 1
- }
- foreachport $portlist {
- # If we have a url, use that, since it's most specific
- # otherwise try to map the portname to a url
- if {$porturl eq ""} {
- # Verify the portname, getting portinfo to map to a porturl
- if {[catch {mportlookup $portname} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Port $portname not found" 1 status
- }
- array unset portinfo
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
- set portdir $portinfo(portdir)
- set portname $portinfo(name)
- } elseif {$porturl ne "file://."} {
- # Extract the portdir from porturl and use it to search PortIndex.
- # Only the last two elements of the path (porturl) make up the
- # portdir.
- set portdir [file split [macports::getportdir $porturl]]
- set lsize [llength $portdir]
- set portdir \
- [file join [lindex $portdir [expr {$lsize - 2}]] \
- [lindex $portdir [expr {$lsize - 1}]]]
- if {[catch {mportsearch $portdir no exact portdir} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Portdir $portdir not found" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Portdir $portdir not found" 1 status
- }
- array unset portinfo
- set matchindex [lsearch -exact -nocase $result $portname]
- if {$matchindex != -1} {
- array set portinfo [lindex $result [incr matchindex]]
- } else {
- ui_warn "Portdir $portdir doesn't seem to belong to portname $portname"
- array set portinfo [lindex $result 1]
- }
- set portname $portinfo(name)
- }
- set portpath [macports::getportdir $porturl]
- set logfile [file join [macports::getportlogpath $portpath $portname] "main.log"]
- if {[file exists $logfile]} {
- if {[catch {set fp [open $logfile r]} result]} {
- break_softcontinue "Could not open file $logfile: $result" 1 status
- }
- set data [read $fp]
- set data [split $data "\n"]
-
- if {[info exists global_options(ports_log_phase)]} {
- set phase $global_options(ports_log_phase);
- } else {
- set phase "\[a-z\]*"
- }
-
- if {[info exists global_options(ports_log_level)]} {
- set index [lsearch -exact ${macports::ui_priorities} $global_options(ports_log_level)]
- if {$index == -1} {
- set prefix ""
- } else {
- set prefix [join [lrange ${macports::ui_priorities} 0 $index] "|"]
- }
- } else {
- set prefix "\[a-z\]*"
- }
- foreach line $data {
- set exp "^:($prefix|any):($phase|any) (.*)$"
- if {[regexp $exp $line -> lpriority lphase lmsg] == 1} {
- puts "[macports::ui_prefix_default $lpriority]$lmsg"
- }
- }
-
- close $fp
- } else {
- break_softcontinue "Log file for port $portname not found" 1 status
- }
- }
- return 0
-}
-
-
-proc action_info { action portlist opts } {
- global global_variations
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
-
- set separator ""
- foreachport $portlist {
- set index_only 0
- if {[info exists options(ports_info_index)] && $options(ports_info_index)} {
- set index_only 1
- }
- puts -nonewline $separator
- array unset portinfo
- # If we have a url, use that, since it's most specific
- # otherwise try to map the portname to a url
- if {$porturl eq "" || $index_only} {
- # Verify the portname, getting portinfo to map to a porturl
- if {[catch {mportlookup $portname} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Port $portname not found" 1 status
- }
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
- set portdir $portinfo(portdir)
- }
-
- if {!$index_only} {
- # Add any global_variations to the variations
- # specified for the port (so we get e.g. dependencies right)
- array unset merged_variations
- array set merged_variations [array get variations]
- foreach { variation value } [array get global_variations] {
- if { ![info exists merged_variations($variation)] } {
- set merged_variations($variation) $value
- }
- }
- if {![info exists options(subport)]} {
- if {[info exists portinfo(name)]} {
- set options(subport) $portinfo(name)
- } else {
- set options(subport) $portname
- }
- }
-
- if {[catch {set mport [mportopen $porturl [array get options] [array get merged_variations]]} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Unable to open port: $result" 1 status
- }
- unset options(subport)
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
- if {[info exists portdir]} {
- set portinfo(portdir) $portdir
- }
- } elseif {![info exists portinfo]} {
- ui_warn "no PortIndex entry found for $portname"
- continue
- }
- array unset options ports_info_index
-
- # Understand which info items are actually lists
- # (this could be overloaded to provide a generic formatting code to
- # allow us to, say, split off the prefix on libs)
- array set list_map "
- categories 1
- depends_fetch 1
- depends_extract 1
- depends_build 1
- depends_lib 1
- depends_run 1
- maintainers 1
- platforms 1
- variants 1
- conflicts 1
- subports 1
- "
-
- # Label map for pretty printing
- array set pretty_label {
- heading ""
- variants Variants
- depends_fetch "Fetch Dependencies"
- depends_extract "Extract Dependencies"
- depends_build "Build Dependencies"
- depends_run "Runtime Dependencies"
- depends_lib "Library Dependencies"
- description "Brief Description"
- long_description "Description"
- fullname "Full Name: "
- homepage Homepage
- platforms Platforms
- maintainers Maintainers
- license License
- conflicts "Conflicts with"
- replaced_by "Replaced by"
- subports "Sub-ports"
- }
-
- # Wrap-length map for pretty printing
- array set pretty_wrap {
- heading 0
- replaced_by 22
- variants 22
- depends_fetch 22
- depends_extract 22
- depends_build 22
- depends_run 22
- depends_lib 22
- description 22
- long_description 22
- homepage 22
- platforms 22
- license 22
- conflicts 22
- maintainers 22
- subports 22
- }
-
- # Interpret a convenient field abbreviation
- if {[info exists options(ports_info_depends)] && $options(ports_info_depends) eq "yes"} {
- array unset options ports_info_depends
- set options(ports_info_depends_fetch) yes
- set options(ports_info_depends_extract) yes
- set options(ports_info_depends_build) yes
- set options(ports_info_depends_lib) yes
- set options(ports_info_depends_run) yes
- }
-
- # Set up our field separators
- set show_label 1
- set field_sep "\n"
- set subfield_sep ", "
- set pretty_print 0
-
- # For human-readable summary, which is the default with no options
- if {[llength [array get options ports_info_*]] == 0} {
- set pretty_print 1
- } elseif {[info exists options(ports_info_pretty)]} {
- set pretty_print 1
- array unset options ports_info_pretty
- }
-
- # Tune for sort(1)
- if {[info exists options(ports_info_line)]} {
- array unset options ports_info_line
- set noseparator 1
- set show_label 0
- set field_sep "\t"
- set subfield_sep ","
- }
-
- # Figure out whether to show field name
- set quiet [macports::ui_isset ports_quiet]
- if {$quiet} {
- set show_label 0
- }
- # In pretty-print mode we also suppress messages, even though we show
- # most of the labels:
- if {$pretty_print} {
- set quiet 1
- }
-
- # Spin through action options, emitting information for any found
- set fields {}
- set opts_todo [array names options ports_info_*]
- set fields_tried {}
- if {![llength $opts_todo]} {
- set opts_todo {ports_info_heading
- ports_info_replaced_by
- ports_info_subports
- ports_info_variants
- ports_info_skip_line
- ports_info_long_description ports_info_homepage
- ports_info_skip_line ports_info_depends_fetch
- ports_info_depends_extract ports_info_depends_build
- ports_info_depends_lib ports_info_depends_run
- ports_info_conflicts
- ports_info_platforms ports_info_license
- ports_info_maintainers
- }
- }
- foreach { option } $opts_todo {
- set opt [string range $option 11 end]
- # Artificial field name for formatting
- if {$pretty_print && $opt eq "skip_line"} {
- lappend fields ""
- continue
- }
- # Artificial field names to reproduce prettyprinted summary
- if {$opt eq "heading"} {
- set inf "$portinfo(name) @$portinfo(version)"
- set ropt "heading"
- if {[info exists portinfo(revision)] && $portinfo(revision) > 0} {
- append inf "_$portinfo(revision)"
- }
- if {[info exists portinfo(categories)]} {
- append inf " ([join $portinfo(categories) ", "])"
- }
- } elseif {$opt eq "fullname"} {
- set inf "$portinfo(name) @"
- append inf [composite_version $portinfo(version) $portinfo(active_variants)]
- set ropt "fullname"
- } else {
- # Map from friendly name
- set ropt [map_friendly_field_names $opt]
-
- # If there's no such info, move on
- if {![info exists portinfo($ropt)]} {
- set inf ""
- } else {
- set inf [join $portinfo($ropt)]
- }
- }
-
- # Calculate field label
- set label ""
- if {$pretty_print} {
- if {[info exists pretty_label($ropt)]} {
- set label $pretty_label($ropt)
- } else {
- set label $opt
- }
- } elseif {$show_label} {
- set label "$opt: "
- }
-
- # Format the data
- if { $ropt eq "maintainers" } {
- set inf [unobscure_maintainers $inf]
- }
- # ... special formatting for certain fields when prettyprinting
- if {$pretty_print} {
- if {$ropt eq "variants"} {
- # Use the new format for variants iff it exists in
- # PortInfo. This key currently does not exist outside of
- # trunk (1.8.0).
- array unset vinfo
- if {[info exists portinfo(vinfo)]} {
- array set vinfo $portinfo(vinfo)
- }
-
- set pi_vars $inf
- set inf {}
- foreach v [lsort $pi_vars] {
- set varmodifier ""
- if {[info exists variations($v)]} {
- # selected by command line, prefixed with +/-
- set varmodifier $variations($v)
- } elseif {[info exists global_variations($v)]} {
- # selected by variants.conf, prefixed with (+)/(-)
- set varmodifier "($global_variations($v))"
- # Retrieve additional information from the new key.
- } elseif {[info exists vinfo]} {
- array unset variant
- array set variant $vinfo($v)
- if {[info exists variant(is_default)]} {
- set varmodifier "\[$variant(is_default)]"
- }
- }
- lappend inf "$varmodifier$v"
- }
- } elseif {[string match "depend*" $ropt]
- && ![macports::ui_isset ports_verbose]} {
- set pi_deps $inf
- set inf {}
- foreach d $pi_deps {
- lappend inf [lindex [split $d :] end]
- }
- }
- }
- #End of special pretty-print formatting for certain fields
- if {[info exists list_map($ropt)]} {
- set field [join $inf $subfield_sep]
- } else {
- set field $inf
- }
-
- # Assemble the entry
- if {$pretty_print} {
- # The two special fields are considered headings and are
- # emitted immediately, rather than waiting. Also they are not
- # recorded on the list of fields tried
- if {$ropt eq "heading" || $ropt eq "fullname"} {
- puts "$label$field"
- continue
- }
- }
- lappend fields_tried $label
- if {$pretty_print} {
- if {$field eq ""} {
- continue
- }
- if {$label eq ""} {
- set wrap_len 0
- if {[info exists pretty_wrap($ropt)]} {
- set wrap_len $pretty_wrap($ropt)
- }
- lappend fields [wrap $field 0 [string repeat " " $wrap_len]]
- } else {
- set wrap_len [string length $label]
- if {[info exists pretty_wrap($ropt)]} {
- set wrap_len $pretty_wrap($ropt)
- }
- lappend fields [wraplabel $label $field 0 [string repeat " " $wrap_len]]
- }
-
- } else { # Not pretty print
- lappend fields "$label$field"
- }
- }
-
- # Now output all that information:
- if {[llength $fields]} {
- puts [join $fields $field_sep]
- } else {
- if {$pretty_print && [llength $fields_tried]} {
- puts -nonewline "$portinfo(name) has no "
- puts [join $fields_tried ", "]
- }
- }
- if {![info exists noseparator]} {
- set separator "--\n"
- }
- }
-
- return $status
-}
-
-
-proc action_location { action portlist opts } {
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
- foreachport $portlist {
- if { [catch {set ilist [registry_installed $portname [composite_version $portversion [array get variations]]]} result] } {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port location failed: $result" 1 status
- } else {
- # set portname again since the one we were passed may not have had the correct case
- set portname [lindex $ilist 0]
- set version [lindex $ilist 1]
- set revision [lindex $ilist 2]
- set variants [lindex $ilist 3]
- set epoch [lindex $ilist 5]
- }
-
- set ref [registry::open_entry $portname $version $revision $variants $epoch]
- set imagedir [registry::property_retrieve $ref location]
- ui_notice "Port $portname ${version}_${revision}${variants} is installed as an image in:"
- puts $imagedir
- }
-
- return $status
-}
-
-
-proc action_notes { action portlist opts } {
- if {[require_portlist portlist]} {
- return 1
- }
-
- set status 0
- foreachport $portlist {
- array unset portinfo
- if {$porturl eq ""} {
- # Look up the port.
- if {[catch {mportlookup $portname} result]} {
- ui_debug $::errorInfo
- break_softcontinue "The lookup of '$portname' failed: $result" \
- 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "The port '$portname' was not found" 1 status
- }
-
- # Retrieve the port's URL.
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
- }
-
- # Add any global_variations to the variations
- # specified for the port
- array unset merged_variations
- array set merged_variations [array get variations]
- foreach { variation value } [array get global_variations] {
- if { ![info exists merged_variations($variation)] } {
- set merged_variations($variation) $value
- }
- }
- if {![info exists options(subport)]} {
- if {[info exists portinfo(name)]} {
- set options(subport) $portinfo(name)
- } else {
- set options(subport) $portname
- }
- }
-
- # Open the Portfile associated with this port.
- if {[catch {set mport [mportopen $porturl [array get options] \
- [array get merged_variations]]} \
- result]} {
- ui_debug $::errorInfo
- break_softcontinue [concat "The URL '$porturl' could not be" \
- "opened: $result"] 1 status
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
-
- # Return the notes associated with this Portfile.
- if {[info exists portinfo(notes)]} {
- set portnotes $portinfo(notes)
- } else {
- set portnotes {}
- }
-
- # Retrieve the port's name once more to ensure it has the proper case.
- set portname $portinfo(name)
-
- # Display the notes.
- if {$portnotes ne {}} {
- ui_notice "$portname has the following notes:"
- foreach note $portnotes {
- puts [wrap $note 0 " " 1]
- }
- } else {
- puts "$portname has no notes."
- }
- }
- return $status
-}
-
-
-proc action_provides { action portlist opts } {
- # In this case, portname is going to be used for the filename... since
- # that is the first argument we expect... perhaps there is a better way
- # to do this?
- if { ![llength $portlist] } {
- ui_error "Please specify a filename to check which port provides that file."
- return 1
- }
- foreach filename $portlist {
- set file [file normalize $filename]
- if {[file exists $file] || ![catch {file type $file}]} {
- if {![file isdirectory $file] || [file type $file] eq "link"} {
- set port [registry::file_registered $file]
- if { $port != 0 } {
- puts "$file is provided by: $port"
- } else {
- puts "$file is not provided by a MacPorts port."
- }
- } else {
- puts "$file is a directory."
- }
- } else {
- puts "$file does not exist."
- }
- }
- registry::close_file_map
-
- return 0
-}
-
-
-proc action_activate { action portlist opts } {
- set status 0
- if {[require_portlist portlist] || [prefix_unwritable]} {
- return 1
- }
- foreachport $portlist {
- set composite_version [composite_version $portversion [array get variations]]
- if {![info exists options(ports_activate_no-exec)]
- && ![catch {set ilist [registry::installed $portname $composite_version]}]
- && [llength $ilist] == 1} {
-
- set i [lindex $ilist 0]
- set regref [registry::entry open $portname [lindex $i 1] [lindex $i 2] [lindex $i 3] [lindex $i 5]]
- if {[$regref installtype] eq "image" && [registry::run_target $regref activate [array get options]]} {
- continue
- }
- }
- if {![macports::global_option_isset ports_dryrun]} {
- if { [catch {portimage::activate_composite $portname $composite_version [array get options]} result] } {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port activate failed: $result" 1 status
- }
- } else {
- ui_msg "Skipping activate $portname (dry run)"
- }
- }
-
- return $status
-}
-
-
-proc action_deactivate { action portlist opts } {
- set status 0
- if {[require_portlist portlist] || [prefix_unwritable]} {
- return 1
- }
- set portlist [portlist_sortdependents $portlist]
- foreachport $portlist {
- set composite_version [composite_version $portversion [array get variations]]
- if {![info exists options(ports_deactivate_no-exec)]
- && ![catch {set ilist [registry::active $portname]}]} {
-
- set i [lindex $ilist 0]
- set iversion [lindex $i 1]
- set irevision [lindex $i 2]
- set ivariants [lindex $i 3]
- if {$composite_version eq "" || $composite_version == "${iversion}_${irevision}${ivariants}"} {
- set regref [registry::entry open $portname $iversion $irevision $ivariants [lindex $i 5]]
- if {[$regref installtype] eq "image" && [registry::run_target $regref deactivate [array get options]]} {
- continue
- }
- }
- }
- if {![macports::global_option_isset ports_dryrun]} {
- if { [catch {portimage::deactivate_composite $portname $composite_version [array get options]} result] } {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port deactivate failed: $result" 1 status
- }
- } else {
- ui_msg "Skipping deactivate $portname (dry run)"
- }
- }
-
- return $status
-}
-
-
-proc action_select { action portlist opts } {
- ui_debug "action_select \[$portlist] \[$opts]..."
-
- array set opts_array $opts
- set commands [array names opts_array ports_select_*]
- array unset opts_array
-
- # Error out if no group is specified or command is not --summary.
- if {[llength $portlist] < 1 && [string map {ports_select_ ""} [lindex $commands 0]] != "summary"} {
- ui_error "port select \[--list|--set|--show|--summary] \<group> \[<version>]"
- return 1
- }
-
- set group [lindex $portlist 0]
-
- # If no command (--set, --show, --list, --summary) is specified *but*
- # more than one argument is specified, default to the set command.
- if {[llength $commands] < 1 && [llength $portlist] > 1} {
- set command set
- ui_debug [concat "Although no command was specified, more than " \
- "one argument was specified. Defaulting to the " \
- "'set' command..."]
- # If no command (--set, --show, --list) is specified *and* less than two
- # argument are specified, default to the list command.
- } elseif {[llength $commands] < 1} {
- set command list
- ui_debug [concat "No command was specified. Defaulting to the " \
- "'list' command..."]
- # Only allow one command to be specified at a time.
- } elseif {[llength $commands] > 1} {
- ui_error [concat "Multiple commands were specified. Only one " \
- "command may be specified at a time."]
- return 1
- } else {
- set command [string map {ports_select_ ""} [lindex $commands 0]]
- ui_debug "The '$command' command was specified."
- }
-
- switch -- $command {
- list {
- if {[llength $portlist] > 1} {
- ui_warn [concat "The 'list' command does not expect any " \
- "arguments. Extra arguments will be ignored."]
- }
-
- if {[catch {mportselect show $group} selected_version]} {
- global errorInfo
- ui_debug $errorInfo
- ui_warn "Unable to get active selected version: $selected_version"
- }
-
- # On error mportselect returns with the code 'error'.
- if {[catch {mportselect $command $group} versions]} {
- ui_error "The 'list' command failed: $versions"
- return 1
- }
-
- ui_notice "Available versions for $group:"
- foreach v $versions {
- ui_notice -nonewline "\t"
- if {$selected_version == $v} {
- ui_msg "$v (active)"
- } else {
- ui_msg "$v"
- }
- }
- return 0
- }
- set {
- if {[llength $portlist] < 2} {
- ui_error [concat "The 'set' command expects two " \
- "arguments: <group>, <version>"]
- return 1
- } elseif {[llength $portlist] > 2} {
- ui_warn [concat "The 'set' command only expects two " \
- "arguments. Extra arguments will be " \
- "ignored."]
- }
- set version [lindex $portlist 1]
-
- ui_msg -nonewline "Selecting '$version' for '$group' "
- if {[catch {mportselect $command $group $version} result]} {
- ui_msg "failed: $result"
- return 1
- }
- ui_msg "succeeded. '$version' is now active."
- return 0
- }
- show {
- if {[llength $portlist] > 1} {
- ui_warn [concat "The 'show' command does not expect any " \
- "arguments. Extra arguments will be ignored."]
- }
-
- if {[catch {mportselect $command $group} selected_version]} {
- ui_error "The 'show' command failed: $selected_version"
- return 1
- }
- puts [concat "The currently selected version for '$group' is " \
- "'$selected_version'."]
- return 0
- }
- summary {
- if {[llength $portlist] > 0} {
- ui_warn [concat "The 'summary' command does not expect any " \
- "arguments. Extra arguments will be ignored."]
- }
-
- if {[catch {mportselect $command} portgroups]} {
- ui_error "The 'summary' command failed: $portgroups"
- return 1
- }
-
- set w1 4
- set w2 8
- set formatStr "%-*s %-*s %s"
-
- set groups [list]
- foreach pg $portgroups {
- array set groupdesc {}
- set groupdesc(name) [string trim $pg]
-
- if {[catch {mportselect list $pg} versions]} {
- ui_warn "The list of options for the select group $pg could not be obtained: $versions"
- continue
- }
- # remove "none", sort the list, append none at the end
- set noneidx [lsearch -exact $versions "none"]
- set versions [lsort [lreplace $versions $noneidx $noneidx]]
- lappend versions "none"
- set groupdesc(versions) $versions
-
- if {[catch {mportselect show $pg} selected_version]} {
- ui_warn "The currently selected option for the select group $pg could not be obtained: $selected_version"
- continue
- }
- set groupdesc(selected) $selected_version
-
- set w1 [expr {max($w1, [string length $pg])}]
- set w2 [expr {max($w2, [string length $selected_version])}]
-
- lappend groups [array get groupdesc]
- array unset groupdesc
- }
- puts [format $formatStr $w1 "Name" $w2 "Selected" "Options"]
- puts [format $formatStr $w1 "====" $w2 "========" "======="]
- foreach groupdesc $groups {
- array set groupd $groupdesc
- puts [format $formatStr $w1 $groupd(name) $w2 $groupd(selected) [join $groupd(versions) " "]]
- array unset groupd
- }
- return 0
- }
- default {
- ui_error "An unknown command '$command' was specified."
- return 1
- }
- }
-}
-
-
-proc action_selfupdate { action portlist opts } {
- global global_options
- if { [catch {macports::selfupdate [array get global_options] base_updated} result ] } {
- global errorInfo
- ui_debug "$errorInfo"
- ui_error "$result"
- if {![macports::ui_isset ports_verbose]} {
- ui_msg "Please run `port -v selfupdate' for details."
- } else {
- # Let's only print the ticket URL if the user has followed the
- # advice we printed earlier.
- print_tickets_url
- }
- fatal "port selfupdate failed: $result"
- }
-
- if {$base_updated} {
- # exit immediately if in batch/interactive mode
- return -999
- } else {
- return 0
- }
-}
-
-
-proc action_setrequested { action portlist opts } {
- set status 0
- if {[require_portlist portlist] || [prefix_unwritable]} {
- return 1
- }
- # set or unset?
- set val [string equal $action "setrequested"]
- foreachport $portlist {
- set composite_version [composite_version $portversion [array get variations]]
- if {![catch {set ilist [registry::installed $portname $composite_version]} result]} {
- ui_info "Setting requested flag for $portname to $val"
- foreach i $ilist {
- set regref [registry::open_entry $portname [lindex $i 1] [lindex $i 2] [lindex $i 3] [lindex $i 5]]
- registry::property_store $regref requested $val
- }
- } else {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "$result" 1 status
- }
- }
-
- return $status
-}
-
-
-proc action_upgrade { action portlist opts } {
- if {[require_portlist portlist "yes"] || ([prefix_unwritable] && ![macports::global_option_isset ports_dryrun])} {
- return 1
- }
-
- # shared depscache for all ports in the list
- array set depscache {}
- set status 0
- foreachport $portlist {
- if {![info exists depscache(port:$portname)]} {
- set status [macports::upgrade $portname "port:$portname" [array get requested_variations] [array get options] depscache]
- # status 2 means the port was not found in the index,
- # status 3 means the port is not installed
- if {$status != 0 && $status != 2 && $status != 3 && ![macports::ui_isset ports_processall]} {
- break
- }
- }
- }
-
- if {$status != 0 && $status != 2 && $status != 3} {
- print_tickets_url
- } elseif {$status == 0} {
- array set options $opts
- if {![info exists options(ports_upgrade_no-rev-upgrade)] && ${macports::revupgrade_autorun} && ![macports::global_option_isset ports_dryrun]} {
- set status [action_revupgrade $action $portlist $opts]
- }
- }
-
- return $status
-}
-
-proc action_doctor { action portlist opts } {
- if {[prefix_unwritable]} {
- return 1
- }
- macports::doctor_main $opts
- return 0
-}
-
-proc action_reclaim { action portlist opts } {
- if {[prefix_unwritable]} {
- return 1
- }
- macports::reclaim_main
- return 0
-}
-
-proc action_revupgrade { action portlist opts } {
- set status [macports::revupgrade $opts]
- if {$status != 0} {
- print_tickets_url
- }
- return $status
-}
-
-
-proc action_version { action portlist opts } {
- if {![macports::ui_isset ports_quiet]} {
- puts -nonewline "Version: "
- }
- puts [macports::version]
- return 0
-}
-
-
-proc action_platform { action portlist opts } {
- if {![macports::ui_isset ports_quiet]} {
- puts -nonewline "Platform: "
- }
- puts "${macports::os_platform} ${macports::os_major} ${macports::os_arch}"
- return 0
-}
-
-
-proc action_dependents { action portlist opts } {
- if {[require_portlist portlist]} {
- return 1
- }
- set ilist {}
-
- registry::open_dep_map
-
- set status 0
- foreachport $portlist {
- set composite_version [composite_version $portversion [array get variations]]
- if { [catch {set ilist [registry::installed $portname $composite_version]} result] } {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "$result" 1 status
- } else {
- # choose the active version if there is one
- set index 0
- foreach i $ilist {
- if {[lindex $i 4]} {
- set found 1
- break
- }
- incr index
- }
- if {![info exists found]} {
- set index 0
- }
- # set portname again since the one we were passed may not have had the correct case
- set portname [lindex $ilist $index 0]
- set iversion [lindex $ilist $index 1]
- set irevision [lindex $ilist $index 2]
- set ivariants [lindex $ilist $index 3]
- }
-
- set deplist [registry::list_dependents $portname $iversion $irevision $ivariants]
- if { [llength $deplist] > 0 } {
- if {$action eq "rdependents"} {
- set toplist $deplist
- while 1 {
- set newlist {}
- foreach dep $deplist {
- set depname [lindex $dep 2]
- if {![info exists seen($depname)]} {
- set seen($depname) 1
- set rdeplist [registry::list_dependents $depname]
- foreach rdep $rdeplist {
- lappend newlist $rdep
- }
- set dependentsof($depname) $rdeplist
- }
- }
- if {[llength $newlist] > 0} {
- set deplist $newlist
- } else {
- break
- }
- }
- set portstack [list $toplist]
- set pos_stack [list 0]
- array unset seen
- ui_notice "The following ports are dependent on ${portname}:"
- while 1 {
- set cur_portlist [lindex $portstack end]
- set cur_pos [lindex $pos_stack end]
- if {$cur_pos >= [llength $cur_portlist]} {
- set portstack [lreplace $portstack end end]
- set pos_stack [lreplace $pos_stack end end]
- if {[llength $portstack] <= 0} {
- break
- } else {
- continue
- }
- }
- set cur_port [lindex $cur_portlist $cur_pos]
- set cur_portname [lindex $cur_port 2]
- set spaces [string repeat " " [expr {[llength $pos_stack] * 2}]]
- if {![info exists seen($cur_portname)] || ([info exists options(ports_rdependents_full)] && [string is true -strict $options(ports_rdependents_full)])} {
- puts "${spaces}${cur_portname}"
- set seen($cur_portname) 1
- incr cur_pos
- set pos_stack [lreplace $pos_stack end end $cur_pos]
- if {[info exists dependentsof($cur_portname)]} {
- lappend portstack $dependentsof($cur_portname)
- lappend pos_stack 0
- }
- continue
- }
- incr cur_pos
- set pos_stack [lreplace $pos_stack end end $cur_pos]
- }
- } else {
- foreach dep $deplist {
- set depport [lindex $dep 2]
- if {[macports::ui_isset ports_quiet]} {
- ui_msg "$depport"
- } elseif {![macports::ui_isset ports_verbose]} {
- ui_msg "$depport depends on $portname"
- } else {
- ui_msg "$depport depends on $portname (by [lindex $dep 1]:)"
- }
- }
- }
- } else {
- ui_notice "$portname has no dependents."
- }
- }
- return $status
-}
-
-
-proc action_deps { action portlist opts } {
- global global_variations
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
- set separator ""
-
- foreachport $portlist {
- if {[info exists options(ports_${action}_no-build)] && [string is true -strict $options(ports_${action}_no-build)]} {
- set deptypes {depends_lib depends_run}
- } else {
- set deptypes {depends_fetch depends_extract depends_build depends_lib depends_run}
- }
-
- array unset portinfo
- # If we have a url, use that, since it's most specific
- # otherwise try to map the portname to a url
- if {$porturl eq ""} {
- # Verify the portname, getting portinfo to map to a porturl
- if {[catch {mportlookup $portname} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Port $portname not found" 1 status
- }
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
- } elseif {$porturl ne "file://."} {
- # Extract the portdir from porturl and use it to search PortIndex.
- # Only the last two elements of the path (porturl) make up the
- # portdir.
- set portdir [file split [macports::getportdir $porturl]]
- set lsize [llength $portdir]
- set portdir \
- [file join [lindex $portdir [expr {$lsize - 2}]] \
- [lindex $portdir [expr {$lsize - 1}]]]
- if {[catch {mportsearch $portdir no exact portdir} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Portdir $portdir not found" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Portdir $portdir not found" 1 status
- }
- set matchindex [lsearch -exact -nocase $result $portname]
- if {$matchindex != -1} {
- array set portinfo [lindex $result [incr matchindex]]
- } else {
- ui_warn "Portdir $portdir doesn't seem to belong to portname $portname"
- array set portinfo [lindex $result 1]
- }
- }
-
- if {!([info exists options(ports_${action}_index)] && $options(ports_${action}_index) eq "yes")} {
- # Add any global_variations to the variations
- # specified for the port, so we get dependencies right
- array unset merged_variations
- array set merged_variations [array get variations]
- foreach { variation value } [array get global_variations] {
- if { ![info exists merged_variations($variation)] } {
- set merged_variations($variation) $value
- }
- }
- if {![info exists options(subport)]} {
- if {[info exists portinfo(name)]} {
- set options(subport) $portinfo(name)
- } else {
- set options(subport) $portname
- }
- }
- if {[catch {set mport [mportopen $porturl [array get options] [array get merged_variations]]} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Unable to open port: $result" 1 status
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
- } elseif {![info exists portinfo]} {
- ui_warn "port ${action} --index does not work with the 'current' pseudo-port"
- continue
- }
- set portname $portinfo(name)
-
- set deplist {}
- set deps_output {}
- set ndeps 0
- array set labeldict {depends_fetch Fetch depends_extract Extract depends_build Build depends_lib Library depends_run Runtime}
- # get list of direct deps
- foreach type $deptypes {
- if {[info exists portinfo($type)]} {
- if {$action eq "rdeps" || [macports::ui_isset ports_verbose]} {
- foreach dep $portinfo($type) {
- lappend deplist $dep
- }
- } else {
- foreach dep $portinfo($type) {
- lappend deplist [lindex [split $dep :] end]
- }
- }
- if {$action eq "deps"} {
- set label "$labeldict($type) Dependencies"
- lappend deps_output [wraplabel $label [join $deplist ", "] 0 [string repeat " " 22]]
- incr ndeps [llength $deplist]
- set deplist {}
- }
- }
- }
-
- set version $portinfo(version)
- set revision $portinfo(revision)
- if {[info exists portinfo(canonical_active_variants)]} {
- set variants $portinfo(canonical_active_variants)
- } else {
- set variants {}
- }
-
- puts -nonewline $separator
- if {$action eq "deps"} {
- if {$ndeps == 0} {
- ui_notice "$portname @${version}_${revision}${variants} has no dependencies."
- } else {
- ui_notice "Full Name: $portname @${version}_${revision}${variants}"
- puts [join $deps_output "\n"]
- }
- set separator "--\n"
- continue
- }
-
- set toplist $deplist
- # gather all the deps
- while 1 {
- set newlist {}
- foreach dep $deplist {
- set depname [lindex [split $dep :] end]
- if {![info exists seen($depname)]} {
- set seen($depname) 1
-
- # look up the dep
- if {[catch {mportlookup $depname} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "lookup of portname $depname failed: $result" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Port $depname not found" 1 status
- }
- array unset portinfo
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
- set options(subport) $portinfo(name)
-
- # open the portfile if requested
- if {!([info exists options(ports_${action}_index)] && $options(ports_${action}_index) eq "yes")} {
- if {[catch {set mport [mportopen $porturl [array get options] [array get merged_variations]]} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Unable to open port: $result" 1 status
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
- }
-
- # get list of the dep's deps
- set rdeplist {}
- foreach type $deptypes {
- if {[info exists portinfo($type)]} {
- foreach rdep $portinfo($type) {
- lappend rdeplist $rdep
- lappend newlist $rdep
- }
- }
- }
- set depsof($depname) $rdeplist
- }
- }
- if {[llength $newlist] > 0} {
- set deplist $newlist
- } else {
- break
- }
- }
- set portstack [list $toplist]
- set pos_stack [list 0]
- array unset seen
- if {[llength $toplist] > 0} {
- ui_notice "The following ports are dependencies of $portname @${version}_${revision}${variants}:"
- } else {
- ui_notice "$portname @${version}_${revision}${variants} has no dependencies."
- }
- while 1 {
- set cur_portlist [lindex $portstack end]
- set cur_pos [lindex $pos_stack end]
- if {$cur_pos >= [llength $cur_portlist]} {
- set portstack [lreplace $portstack end end]
- set pos_stack [lreplace $pos_stack end end]
- if {[llength $portstack] <= 0} {
- break
- } else {
- continue
- }
- }
- set cur_port [lindex $cur_portlist $cur_pos]
- set cur_portname [lindex [split $cur_port :] end]
- set spaces [string repeat " " [expr {[llength $pos_stack] * 2}]]
- if {![info exists seen($cur_portname)] || ([info exists options(ports_${action}_full)] && [string is true -strict $options(ports_${action}_full)])} {
- if {[macports::ui_isset ports_verbose]} {
- puts "${spaces}${cur_port}"
- } else {
- puts "${spaces}${cur_portname}"
- }
- set seen($cur_portname) 1
- incr cur_pos
- set pos_stack [lreplace $pos_stack end end $cur_pos]
- if {[info exists depsof($cur_portname)]} {
- lappend portstack $depsof($cur_portname)
- lappend pos_stack 0
- }
- continue
- }
- incr cur_pos
- set pos_stack [lreplace $pos_stack end end $cur_pos]
- }
- set separator "--\n"
- }
- return $status
-}
-
-
-proc action_uninstall { action portlist opts } {
- set status 0
- if {[macports::global_option_isset port_uninstall_old]} {
- # if -u then uninstall all inactive ports
- # (union these to any other ports user has in the port list)
- set portlist [opUnion $portlist [get_inactive_ports]]
- } else {
- # Otherwise the user hopefully supplied a portlist, or we'll default to the existing directory
- if {[require_portlist portlist]} {
- return 1
- }
- }
- if {[prefix_unwritable]} {
- return 1
- }
-
- set portlist [portlist_sortdependents $portlist]
-
- foreachport $portlist {
- if {![registry::entry_exists_for_name $portname]} {
- # if the code path arrives here the port either isn't installed, or
- # it doesn't exist at all. We can't be sure, but we can check the
- # portindex whether a port by that name exists (in which case not
- # uninstalling it is probably no problem). If there is no port by
- # that name, alert the user in case of typos.
- ui_info "$portname is not installed"
- if {[catch {set res [mportlookup $portname]} result] || [llength $res] == 0} {
- ui_warn "no such port: $portname, skipping uninstall"
- }
- continue
- }
- set composite_version [composite_version $portversion [array get variations]]
- if {![info exists options(ports_uninstall_no-exec)]
- && ![catch {set ilist [registry::installed $portname $composite_version]}]
- && [llength $ilist] == 1} {
-
- set i [lindex $ilist 0]
- set iactive [lindex $i 4]
- set regref [registry::entry open $portname [lindex $i 1] [lindex $i 2] [lindex $i 3] [lindex $i 5]]
- if {[registry::run_target $regref uninstall [array get options]]} {
- continue
- }
- }
-
- if { [catch {registry_uninstall::uninstall_composite $portname $composite_version [array get options]} result] } {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port uninstall failed: $result" 1 status
- }
- }
-
- return $status
-}
-
-
-proc action_installed { action portlist opts } {
- global private_options
- set status 0
- set restrictedList 0
- set ilist {}
-
- if { [llength $portlist] || (![info exists private_options(ports_no_args)] || $private_options(ports_no_args) eq "no")} {
- set restrictedList 1
- foreachport $portlist {
- set composite_version [composite_version $portversion [array get variations]]
- if { [catch {set ilist [concat $ilist [registry::installed $portname $composite_version]]} result] } {
- if {![string match "* not registered as installed." $result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port installed failed: $result" 1 status
- }
- }
- }
- } else {
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- ui_error "port installed failed: $result"
- set status 1
- }
- }
- }
- if { [llength $ilist] > 0 } {
- ui_notice "The following ports are currently installed:"
- foreach i [portlist_sortint $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]
- set extra ""
- set nvariants ""
- if {[macports::ui_isset ports_verbose]} {
- set regref [registry::open_entry $iname $iversion $irevision $ivariants [lindex $i 5]]
- set nvariants [registry::property_retrieve $regref negated_variants]
- if {$nvariants == 0} {
- set nvariants ""
- }
- set os_platform [registry::property_retrieve $regref os_platform]
- set os_major [registry::property_retrieve $regref os_major]
- set archs [registry::property_retrieve $regref archs]
- if {$os_platform != 0 && $os_platform ne "" && $os_major != 0 && $os_major ne ""} {
- append extra " platform='$os_platform $os_major'"
- }
- if {$archs != 0 && $archs ne ""} {
- append extra " archs='$archs'"
- }
- }
- if { $iactive == 0 } {
- puts " $iname @${iversion}_${irevision}${ivariants}${nvariants}${extra}"
- } elseif { $iactive == 1 } {
- puts " $iname @${iversion}_${irevision}${ivariants}${nvariants} (active)${extra}"
- }
- }
- } elseif { $restrictedList } {
- ui_notice "None of the specified ports are installed."
- } else {
- ui_notice "No ports are installed."
- }
-
- return $status
-}
-
-
-proc action_outdated { action portlist opts } {
- global private_options
- set status 0
-
- # If port names were supplied, limit ourselves to those ports, else check all installed ports
- set ilist {}
- set restrictedList 0
- if { [llength $portlist] || (![info exists private_options(ports_no_args)] || $private_options(ports_no_args) eq "no")} {
- set restrictedList 1
- foreach portspec $portlist {
- array set port $portspec
- set portname $port(name)
- set composite_version [composite_version $port(version) $port(variants)]
- if { [catch {set ilist [concat $ilist [registry::installed $portname $composite_version]]} result] } {
- if {![string match "* not registered as installed." $result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port outdated failed: $result" 1 status
- }
- }
- }
- } else {
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- ui_error "port installed failed: $result"
- set status 1
- }
- }
- }
-
- set num_outdated 0
- if { [llength $ilist] > 0 } {
- foreach i [portlist_sortint $ilist] {
-
- # Get information about the installed port
- set portname [lindex $i 0]
- set installed_version [lindex $i 1]
- set installed_revision [lindex $i 2]
- set installed_compound "${installed_version}_${installed_revision}"
-
- set is_active [lindex $i 4]
- if {$is_active == 0} {
- continue
- }
- set installed_epoch [lindex $i 5]
-
- # Get info about the port from the index
- if {[catch {set res [mportlookup $portname]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "search for portname $portname failed: $result" 1 status
- }
- if {[llength $res] < 2} {
- if {[macports::ui_isset ports_debug]} {
- puts "$portname ($installed_compound is installed; the port was not found in the port index)"
- }
- continue
- }
- array unset portinfo
- array set portinfo [lindex $res 1]
-
- # Get information about latest available version and revision
- if {![info exists portinfo(version)]} {
- ui_warn "$portname has no version field"
- continue
- }
- set latest_version $portinfo(version)
- set latest_revision 0
- if {[info exists portinfo(revision)] && $portinfo(revision) > 0} {
- set latest_revision $portinfo(revision)
- }
- set latest_compound "${latest_version}_${latest_revision}"
- set latest_epoch 0
- if {[info exists portinfo(epoch)]} {
- set latest_epoch $portinfo(epoch)
- }
-
- # Compare versions, first checking epoch, then version, then revision
- set epoch_comp_result [expr {$installed_epoch - $latest_epoch}]
- set comp_result [vercmp $installed_version $latest_version]
- if { $comp_result == 0 } {
- set comp_result [expr {$installed_revision - $latest_revision}]
- }
- set reason ""
- if {$epoch_comp_result != 0 && $installed_version != $latest_version} {
- if {($comp_result >= 0 && $epoch_comp_result < 0) || ($comp_result <= 0 && $epoch_comp_result > 0)} {
- set reason { (epoch $installed_epoch $relation $latest_epoch)}
- }
- set comp_result $epoch_comp_result
- } elseif {$comp_result == 0} {
- set regref [registry::open_entry $portname $installed_version $installed_revision [lindex $i 3] $installed_epoch]
- set os_platform_installed [registry::property_retrieve $regref os_platform]
- set os_major_installed [registry::property_retrieve $regref os_major]
- if {$os_platform_installed ne "" && $os_platform_installed != 0
- && $os_major_installed ne "" && $os_major_installed != 0
- && ($os_platform_installed != ${macports::os_platform} || $os_major_installed != ${macports::os_major})} {
- set comp_result -1
- set reason { (platform $os_platform_installed $os_major_installed != ${macports::os_platform} ${macports::os_major})}
- }
- }
-
- # Report outdated (or, for verbose, predated) versions
- if { $comp_result != 0 } {
-
- # Form a relation between the versions
- set flag ""
- if { $comp_result > 0 } {
- set relation ">"
- set flag "!"
- } else {
- set relation "<"
- }
-
- # Emit information
- if {$comp_result < 0 || [macports::ui_isset ports_verbose]} {
-
- if {$num_outdated == 0} {
- ui_notice "The following installed ports are outdated:"
- }
- incr num_outdated
-
- puts [format "%-30s %-24s %1s" $portname "$installed_compound $relation $latest_compound [subst $reason]" $flag]
- }
-
- }
- }
-
- if {$num_outdated == 0} {
- ui_notice "No installed ports are outdated."
- }
- } elseif { $restrictedList } {
- ui_notice "None of the specified ports are outdated."
- } else {
- ui_notice "No ports are installed."
- }
-
- return $status
-}
-
-
-proc action_contents { action portlist opts } {
- global global_options
- if {[require_portlist portlist]} {
- return 1
- }
- if {[info exists global_options(ports_contents_size)]} {
- set units {}
- if {[info exists global_options(ports_contents_units)]} {
- set units [complete_size_units $global_options(ports_contents_units)]
- }
- set outstring {[format "%12s $file" [filesize $file $units]]}
- } else {
- set outstring { $file}
- }
-
- foreachport $portlist {
- if { ![catch {set ilist [registry::installed $portname]} result] } {
- # set portname again since the one we were passed may not have had the correct case
- set portname [lindex $ilist 0 0]
- }
- set files [registry::port_registered $portname]
- if { $files != 0 } {
- if { [llength $files] > 0 } {
- ui_notice "Port $portname contains:"
- foreach file $files {
- puts [subst $outstring]
- }
- } else {
- ui_notice "Port $portname does not contain any files or is not active."
- }
- } else {
- ui_notice "Port $portname is not installed."
- }
- }
- registry::close_file_map
-
- return 0
-}
-
-# expand abbreviations of size units
-proc complete_size_units {units} {
- if {$units eq "K" || $units eq "Ki"} {
- return "KiB"
- } elseif {$units eq "k"} {
- return "kB"
- } elseif {$units eq "Mi"} {
- return "MiB"
- } elseif {$units eq "M"} {
- return "MB"
- } elseif {$units eq "Gi"} {
- return "GiB"
- } elseif {$units eq "G"} {
- return "GB"
- } else {
- return $units
- }
-}
-
-# Show space used by the given ports' files
-proc action_space {action portlist opts} {
- global global_options
- require_portlist portlist
-
- set units {}
- if {[info exists global_options(ports_space_units)]} {
- set units [complete_size_units $global_options(ports_space_units)]
- }
- set spaceall 0.0
- foreachport $portlist {
- set space 0.0
- set files [registry::port_registered $portname]
- if { $files != 0 } {
- if { [llength $files] > 0 } {
- foreach file $files {
- catch {
- set space [expr {$space + [file size $file]}]
- }
- }
- if {![info exists options(ports_space_total)] || $options(ports_space_total) ne "yes"} {
- set msg "[bytesize $space $units] $portname"
- if { $portversion != {} } {
- append msg " @$portversion"
- }
- puts $msg
- }
- set spaceall [expr {$space + $spaceall}]
- } else {
- puts stderr "Port $portname does not contain any file or is not active."
- }
- } else {
- puts stderr "Port $portname is not installed."
- }
- }
- if {[llength $portlist] > 1 || ([info exists options(ports_space_total)] && $options(ports_space_total) eq "yes")} {
- puts "[bytesize $spaceall $units] total"
- }
- return 0
-}
-
-proc action_variants { action portlist opts } {
- global global_variations
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
- foreachport $portlist {
- array unset portinfo
- if {$porturl eq ""} {
- # look up port
- if {[catch {mportlookup $portname} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Port $portname not found" 1 status
- }
-
- array set portinfo [lindex $result 1]
-
- set porturl $portinfo(porturl)
- set portdir $portinfo(portdir)
- }
-
- if {!([info exists options(ports_variants_index)] && $options(ports_variants_index) eq "yes")} {
- if {![info exists options(subport)]} {
- if {[info exists portinfo(name)]} {
- set options(subport) $portinfo(name)
- } else {
- set options(subport) $portname
- }
- }
- if {[catch {set mport [mportopen $porturl [array get options] [array get variations]]} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Unable to open port: $result" 1 status
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
- if {[info exists portdir]} {
- set portinfo(portdir) $portdir
- }
- } elseif {![info exists portinfo]} {
- ui_warn "port variants --index does not work with 'current' pseudo-port"
- continue
- }
-
- # set portname again since the one we were passed may not have had the correct case
- set portname $portinfo(name)
-
- # if this fails the port doesn't have any variants
- if {![info exists portinfo(variants)]} {
- ui_notice "$portname has no variants"
- } else {
- array unset vinfo
- # Use the new format if it exists.
- if {[info exists portinfo(vinfo)]} {
- array set vinfo $portinfo(vinfo)
- # Otherwise fall back to the old format.
- } elseif {[info exists portinfo(variant_desc)]} {
- array set vdescriptions $portinfo(variant_desc)
- }
-
- # print out all the variants
- ui_notice "$portname has the variants:"
- foreach v [lsort $portinfo(variants)] {
- unset -nocomplain vconflicts vdescription vrequires
- set varmodifier " "
- # Retrieve variants' information from the new format.
- if {[info exists vinfo]} {
- array unset variant
- array set variant $vinfo($v)
-
- # Retrieve conflicts, description, is_default, and
- # vrequires.
- if {[info exists variant(conflicts)]} {
- set vconflicts $variant(conflicts)
- }
- if {[info exists variant(description)]} {
- set vdescription $variant(description)
- }
-
- # XXX Keep these varmodifiers in sync with action_info, or create a wrapper for it
- if {[info exists variations($v)]} {
- set varmodifier " $variations($v)"
- } elseif {[info exists global_variations($v)]} {
- # selected by variants.conf, prefixed with (+)/(-)
- set varmodifier "($global_variations($v))"
- } elseif {[info exists variant(is_default)]} {
- set varmodifier "\[$variant(is_default)\]"
- }
- if {[info exists variant(requires)]} {
- set vrequires $variant(requires)
- }
- # Retrieve variants' information from the old format,
- # which only consists of the description.
- } elseif {[info exists vdescriptions($v)]} {
- set vdescription $vdescriptions($v)
- }
-
- if {[info exists vdescription]} {
- puts [wraplabel "$varmodifier$v" [string trim $vdescription] 0 [string repeat " " [expr 5 + [string length $v]]]]
- } else {
- puts "$varmodifier$v"
- }
- if {[info exists vconflicts]} {
- puts " * conflicts with [string trim $vconflicts]"
- }
- if {[info exists vrequires]} {
- puts " * requires [string trim $vrequires]"
- }
- }
- }
- }
-
- return $status
-}
-
-
-proc action_search { action portlist opts } {
- global private_options global_options
- set status 0
- if {![llength $portlist] && [info exists private_options(ports_no_args)] && $private_options(ports_no_args) eq "yes"} {
- ui_error "You must specify a search pattern"
- return 1
- }
-
- # Copy global options as we are going to modify the array
- array set options [array get global_options]
-
- if {[info exists options(ports_search_depends)] && $options(ports_search_depends) eq "yes"} {
- array unset options ports_search_depends
- set options(ports_search_depends_fetch) yes
- set options(ports_search_depends_extract) yes
- set options(ports_search_depends_build) yes
- set options(ports_search_depends_lib) yes
- set options(ports_search_depends_run) yes
- }
-
- # Array to hold given filters
- array set filters {}
- # Default matchstyle
- set filter_matchstyle "none"
- set filter_case no
- foreach { option } [array names options ports_search_*] {
- set opt [string range $option 13 end]
-
- if { $options($option) ne "yes" } {
- continue
- }
- switch -- $opt {
- exact -
- glob {
- set filter_matchstyle $opt
- continue
- }
- regex {
- set filter_matchstyle regexp
- continue
- }
- case-sensitive {
- set filter_case yes
- continue
- }
- line {
- continue
- }
- }
-
- set filters($opt) "yes"
- }
- # Set default search filter if none was given
- if { [array size filters] == 0 } {
- set filters(name) "yes"
- set filters(description) "yes"
- }
-
- set separator ""
- foreach portname $portlist {
- puts -nonewline $separator
-
- set searchstring $portname
- set matchstyle $filter_matchstyle
- if {$matchstyle eq "none"} {
- # Guess if the given string was a glob expression, if not do a substring search
- if {[string first "*" $portname] == -1 && [string first "?" $portname] == -1} {
- set searchstring "*$portname*"
- }
- set matchstyle glob
- }
-
- set res {}
- set portfound 0
- foreach { opt } [array get filters] {
- # Map from friendly name
- set opt [map_friendly_field_names $opt]
-
- if {[catch {eval set matches \[mportsearch \$searchstring $filter_case \$matchstyle $opt\]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "search for name $portname failed: $result" 1 status
- }
-
- set tmp {}
- foreach {name info} $matches {
- add_to_portlist tmp [concat [list name $name] $info]
- }
- set res [opUnion $res $tmp]
- }
- set res [portlist_sort $res]
-
- set joiner ""
- foreach info $res {
- array unset portinfo
- array set portinfo $info
-
- # XXX is this the right place to verify an entry?
- if {![info exists portinfo(name)]} {
- puts stderr "Invalid port entry, missing portname"
- continue
- }
- if {![info exists portinfo(description)]} {
- puts stderr "Invalid port entry for $portinfo(name), missing description"
- continue
- }
- if {![info exists portinfo(version)]} {
- puts stderr "Invalid port entry for $portinfo(name), missing version"
- continue
- }
-
- if {[macports::ui_isset ports_quiet]} {
- puts $portinfo(name)
- } else {
- if {[info exists options(ports_search_line)]
- && $options(ports_search_line) eq "yes"} {
- # check for ports without category, e.g. replaced_by stubs
- if {[info exists portinfo(categories)]} {
- puts "$portinfo(name)\t$portinfo(version)\t$portinfo(categories)\t$portinfo(description)"
- } else {
- # keep two consecutive tabs in order to provide consistent columns' content
- puts "$portinfo(name)\t$portinfo(version)\t\t$portinfo(description)"
- }
- } else {
- puts -nonewline $joiner
-
- puts -nonewline "$portinfo(name) @$portinfo(version)"
- if {[info exists portinfo(revision)] && $portinfo(revision) > 0} {
- puts -nonewline "_$portinfo(revision)"
- }
- if {[info exists portinfo(categories)]} {
- puts -nonewline " ([join $portinfo(categories) ", "])"
- }
- puts ""
- puts [wrap [join $portinfo(description)] 0 [string repeat " " 4]]
- }
- }
-
- set joiner "\n"
- set portfound 1
- }
- if { !$portfound } {
- ui_notice "No match for $portname found"
- } elseif {[llength $res] > 1} {
- if {(![info exists global_options(ports_search_line)]
- || $global_options(ports_search_line) ne "yes")} {
- ui_notice "\nFound [llength $res] ports."
- }
- }
-
- set separator "--\n"
- }
-
- array unset options
- array unset filters
-
- return $status
-}
-
-
-proc action_list { action portlist opts } {
- global private_options
- set status 0
-
- # Default to list all ports if no portnames are supplied
- if { ![llength $portlist] && [info exists private_options(ports_no_args)] && $private_options(ports_no_args) eq "yes"} {
- add_to_portlist portlist [list name "-all-"]
- }
-
- foreachport $portlist {
- if {$portname eq "-all-"} {
- if {[catch {set res [mportlistall]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "listing all ports failed: $result" 1 status
- }
- } else {
- set search_string [regex_pat_sanitize $portname]
- if {[catch {set res [mportsearch ^$search_string\$ no]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "search for portname $search_string failed: $result" 1 status
- }
- }
-
- foreach {name array} $res {
- array unset portinfo
- array set portinfo $array
- set outdir ""
- if {[info exists portinfo(portdir)]} {
- set outdir $portinfo(portdir)
- }
- puts [format "%-30s @%-14s %s" $portinfo(name) $portinfo(version) $outdir]
- }
- }
-
- return $status
-}
-
-
-proc action_echo { action portlist opts } {
- global global_options
-
- # Simply echo back the port specs given to this command
- foreachport $portlist {
- if {![macports::ui_isset ports_quiet]} {
- set opts {}
- foreach { key value } [array get options] {
- if {![info exists global_options($key)]} {
- lappend opts "$key=$value"
- }
- }
-
- set composite_version [composite_version $portversion [array get variations] 1]
- if { $composite_version ne "" } {
- set ver_field "@$composite_version"
- } else {
- set ver_field ""
- }
- puts [format "%-30s %s %s" $portname $ver_field [join $opts " "]]
- } else {
- puts "$portname"
- }
- }
-
- return 0
-}
-
-
-proc action_portcmds { action portlist opts } {
- # Operations on the port's directory and Portfile
- global env boot_env current_portdir
-
- array set local_options $opts
-
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
- foreachport $portlist {
- array unset portinfo
- # If we have a url, use that, since it's most specific, otherwise try to map the portname to a url
- if {$porturl eq ""} {
-
- # Verify the portname, getting portinfo to map to a porturl
- if {[catch {set res [mportlookup $portname]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $res] < 2} {
- break_softcontinue "Port $portname not found" 1 status
- }
- array set portinfo [lindex $res 1]
- set porturl $portinfo(porturl)
- set portname $portinfo(name)
- }
-
-
- # Calculate portdir, porturl, and portfile from initial porturl
- set portdir [file normalize [macports::getportdir $porturl]]
- set porturl "file://${portdir}"; # Rebuild url so it's fully qualified
- set portfile "${portdir}/Portfile"
-
- # Now execute the specific action
- if {[file readable $portfile]} {
- switch -- $action {
- cat {
- # Copy the portfile to standard output
- set f [open $portfile RDONLY]
- while { ![eof $f] } {
- puts -nonewline [read $f 4096]
- }
- close $f
- }
-
- edit {
- # Edit the port's portfile with the user's editor
-
- # Restore our entire environment from start time.
- # We need it to evaluate the editor, and the editor
- # may want stuff from it as well, like TERM.
- array unset env_save; array set env_save [array get env]
- array unset env *
- if {${macports::macosx_version} eq "10.5"} {
- unsetenv *
- }
- array set env [array get boot_env]
-
- # Find an editor to edit the portfile
- set editor ""
- set editor_var "ports_${action}_editor"
- if {[info exists local_options($editor_var)]} {
- set editor [join $local_options($editor_var)]
- } else {
- foreach ed { MP_EDITOR VISUAL EDITOR } {
- if {[info exists env($ed)]} {
- set editor $env($ed)
- break
- }
- }
- }
-
- # Use a reasonable canned default if no editor specified or set in env
- if { $editor eq "" } { set editor "/usr/bin/vi" }
-
- # Invoke the editor
- if {[catch {eval exec >@stdout <@stdin 2>@stderr $editor {$portfile}} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "unable to invoke editor $editor: $result" 1 status
- }
-
- # Restore internal MacPorts environment
- array unset env *
- if {${macports::macosx_version} eq "10.5"} {
- unsetenv *
- }
- array set env [array get env_save]
- }
-
- dir {
- # output the path to the port's directory
- puts $portdir
- }
-
- work {
- # output the path to the port's work directory
- set workpath [macports::getportworkpath_from_portdir $portdir $portname]
- if {[file exists $workpath]} {
- puts $workpath
- }
- }
-
- cd {
- # Change to the port's directory, making it the default
- # port for any future commands
- set current_portdir $portdir
- }
-
- url {
- # output the url of the port's directory, suitable to feed back in later as a port descriptor
- puts $porturl
- }
-
- file {
- # output the path to the port's portfile
- puts $portfile
- }
-
- logfile {
- set logfile [file join [macports::getportlogpath $portdir $portname] "main.log"]
- if {[file isfile $logfile]} {
- puts $logfile
- } else {
- ui_error "Log file not found for port in $portdir"
- }
- }
-
- gohome {
- set homepage ""
-
- # Get the homepage as read from PortIndex
- if {[info exists portinfo(homepage)]} {
- set homepage $portinfo(homepage)
- }
-
- # If not available, get the homepage for the port by opening the Portfile
- if {$homepage eq "" && ![catch {set ctx [mportopen $porturl]} result]} {
- array set portinfo [mportinfo $ctx]
- if {[info exists portinfo(homepage)]} {
- set homepage $portinfo(homepage)
- }
- mportclose $ctx
- }
-
- # Try to open a browser to the homepage for the given port
- if { $homepage ne "" } {
- if {[catch {system "${macports::autoconf::open_path} '$homepage'"} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "unable to invoke browser using ${macports::autoconf::open_path}: $result" 1 status
- }
- } else {
- ui_error [format "No homepage for %s" $portname]
- }
- }
- }
- } else {
- break_softcontinue "Could not read $portfile" 1 status
- }
- }
-
- return $status
-}
-
-
-proc action_sync { action portlist opts } {
- global global_options
-
- set status 0
- if {[catch {mportsync [array get global_options]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- ui_msg "port sync failed: $result"
- set status 1
- }
-
- return $status
-}
-
-
-proc action_target { action portlist opts } {
- global global_variations
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
- if {($action eq "install" || $action eq "archive") && [prefix_unwritable] && ![macports::global_option_isset ports_dryrun]} {
- return 1
- }
- foreachport $portlist {
- array unset portinfo
- # If we have a url, use that, since it's most specific
- # otherwise try to map the portname to a url
- if {$porturl eq ""} {
- # Verify the portname, getting portinfo to map to a porturl
- if {[catch {set res [mportlookup $portname]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $res] < 2} {
- # don't error for ports that are installed but not in the tree
- if {[registry::entry_exists_for_name $portname]} {
- ui_warn "Skipping $portname (not in the ports tree)"
- continue
- } else {
- break_softcontinue "Port $portname not found" 1 status
- }
- }
- array set portinfo [lindex $res 1]
- set porturl $portinfo(porturl)
- }
-
- # use existing variants iff none were explicitly requested
- if {[array get requested_variations] eq "" && [array get variations] ne ""} {
- array unset requested_variations
- array set requested_variations [array get variations]
- }
-
- # Add any global_variations to the variations
- # specified for the port
- foreach { variation value } [array get global_variations] {
- if { ![info exists requested_variations($variation)] } {
- set requested_variations($variation) $value
- }
- }
-
- # If version was specified, save it as a version glob for use
- # in port actions (e.g. clean).
- if {[string length $portversion]} {
- set options(ports_version_glob) $portversion
- }
- # if installing, mark the port as explicitly requested
- if {$action eq "install"} {
- if {![info exists options(ports_install_unrequested)]} {
- set options(ports_requested) 1
- }
- # we actually activate as well
- set target activate
- } elseif {$action eq "archive"} {
- set target install
- } else {
- set target $action
- }
- if {![info exists options(subport)]} {
- if {[info exists portinfo(name)]} {
- set options(subport) $portinfo(name)
- } else {
- set options(subport) $portname
- }
- }
- if {[catch {set workername [mportopen $porturl [array get options] [array get requested_variations]]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "Unable to open port: $result" 1 status
- }
- if {[catch {set result [mportexec $workername $target]} result]} {
- global errorInfo
- mportclose $workername
- ui_debug "$errorInfo"
- break_softcontinue "Unable to execute port: $result" 1 status
- }
-
- mportclose $workername
-
- # Process any error that wasn't thrown and handled already
- if {$result} {
- print_tickets_url
- break_softcontinue "Processing of port $portname failed" 1 status
- }
- }
-
- if {$status == 0 && $action eq "install" && ![macports::global_option_isset ports_dryrun]} {
- array set options $opts
- if {![info exists options(ports_nodeps)] && ![info exists options(ports_install_no-rev-upgrade)] && ${macports::revupgrade_autorun}} {
- set status [action_revupgrade $action $portlist $opts]
- }
- }
-
- return $status
-}
-
-
-proc action_exit { action portlist opts } {
- # Return a semaphore telling the main loop to quit
- return -999
-}
-
-
-##########################################
-# Command Parsing
-##########################################
-proc moreargs {} {
- global cmd_argn cmd_argc
- return [expr {$cmd_argn < $cmd_argc}]
-}
-
-
-proc lookahead {} {
- global cmd_argn cmd_argc cmd_argv
- if {$cmd_argn < $cmd_argc} {
- return [lindex $cmd_argv $cmd_argn]
- } else {
- return _EOF_
- }
-}
-
-
-proc advance {} {
- global cmd_argn
- incr cmd_argn
-}
-
-
-proc match s {
- if {[lookahead] == $s} {
- advance
- return 1
- }
- return 0
-}
-
-# action_array specifies which action to run on the given command
-# and if the action wants an expanded portlist.
-# The value is a list of the form {action expand},
-# where action is a string and expand a value:
-# 0 none Does not expect any text argument
-# 1 strings Expects some strings as text argument
-# 2 ports Wants an expanded list of ports as text argument
-global action_array
-
-# Define global constants
-const ACTION_ARGS_NONE 0
-const ACTION_ARGS_STRINGS 1
-const ACTION_ARGS_PORTS 2
-
-array set action_array [list \
- usage [list action_usage [ACTION_ARGS_STRINGS]] \
- help [list action_help [ACTION_ARGS_STRINGS]] \
- \
- echo [list action_echo [ACTION_ARGS_PORTS]] \
- \
- info [list action_info [ACTION_ARGS_PORTS]] \
- location [list action_location [ACTION_ARGS_PORTS]] \
- notes [list action_notes [ACTION_ARGS_PORTS]] \
- provides [list action_provides [ACTION_ARGS_STRINGS]] \
- log [list action_log [ACTION_ARGS_PORTS]] \
- \
- activate [list action_activate [ACTION_ARGS_PORTS]] \
- deactivate [list action_deactivate [ACTION_ARGS_PORTS]] \
- \
- select [list action_select [ACTION_ARGS_STRINGS]] \
- \
- sync [list action_sync [ACTION_ARGS_NONE]] \
- selfupdate [list action_selfupdate [ACTION_ARGS_NONE]] \
- \
- setrequested [list action_setrequested [ACTION_ARGS_PORTS]] \
- unsetrequested [list action_setrequested [ACTION_ARGS_PORTS]] \
- \
- upgrade [list action_upgrade [ACTION_ARGS_PORTS]] \
- rev-upgrade [list action_revupgrade [ACTION_ARGS_NONE]] \
- reclaim [list action_reclaim [ACTION_ARGS_NONE]] \
- doctor [list action_doctor [ACTION_ARGS_NONE]] \
- \
- version [list action_version [ACTION_ARGS_NONE]] \
- platform [list action_platform [ACTION_ARGS_NONE]] \
- \
- uninstall [list action_uninstall [ACTION_ARGS_PORTS]] \
- \
- installed [list action_installed [ACTION_ARGS_PORTS]] \
- outdated [list action_outdated [ACTION_ARGS_PORTS]] \
- contents [list action_contents [ACTION_ARGS_PORTS]] \
- space [list action_space [ACTION_ARGS_PORTS]] \
- dependents [list action_dependents [ACTION_ARGS_PORTS]] \
- rdependents [list action_dependents [ACTION_ARGS_PORTS]] \
- deps [list action_deps [ACTION_ARGS_PORTS]] \
- rdeps [list action_deps [ACTION_ARGS_PORTS]] \
- variants [list action_variants [ACTION_ARGS_PORTS]] \
- \
- search [list action_search [ACTION_ARGS_STRINGS]] \
- list [list action_list [ACTION_ARGS_PORTS]] \
- \
- edit [list action_portcmds [ACTION_ARGS_PORTS]] \
- cat [list action_portcmds [ACTION_ARGS_PORTS]] \
- dir [list action_portcmds [ACTION_ARGS_PORTS]] \
- work [list action_portcmds [ACTION_ARGS_PORTS]] \
- cd [list action_portcmds [ACTION_ARGS_PORTS]] \
- url [list action_portcmds [ACTION_ARGS_PORTS]] \
- file [list action_portcmds [ACTION_ARGS_PORTS]] \
- logfile [list action_portcmds [ACTION_ARGS_PORTS]] \
- gohome [list action_portcmds [ACTION_ARGS_PORTS]] \
- \
- fetch [list action_target [ACTION_ARGS_PORTS]] \
- checksum [list action_target [ACTION_ARGS_PORTS]] \
- extract [list action_target [ACTION_ARGS_PORTS]] \
- patch [list action_target [ACTION_ARGS_PORTS]] \
- configure [list action_target [ACTION_ARGS_PORTS]] \
- build [list action_target [ACTION_ARGS_PORTS]] \
- destroot [list action_target [ACTION_ARGS_PORTS]] \
- install [list action_target [ACTION_ARGS_PORTS]] \
- clean [list action_target [ACTION_ARGS_PORTS]] \
- test [list action_target [ACTION_ARGS_PORTS]] \
- lint [list action_target [ACTION_ARGS_PORTS]] \
- livecheck [list action_target [ACTION_ARGS_PORTS]] \
- distcheck [list action_target [ACTION_ARGS_PORTS]] \
- mirror [list action_target [ACTION_ARGS_PORTS]] \
- load [list action_target [ACTION_ARGS_PORTS]] \
- unload [list action_target [ACTION_ARGS_PORTS]] \
- distfiles [list action_target [ACTION_ARGS_PORTS]] \
- \
- archivefetch [list action_target [ACTION_ARGS_PORTS]] \
- archive [list action_target [ACTION_ARGS_PORTS]] \
- unarchive [list action_target [ACTION_ARGS_PORTS]] \
- dmg [list action_target [ACTION_ARGS_PORTS]] \
- mdmg [list action_target [ACTION_ARGS_PORTS]] \
- dpkg [list action_target [ACTION_ARGS_PORTS]] \
- mpkg [list action_target [ACTION_ARGS_PORTS]] \
- pkg [list action_target [ACTION_ARGS_PORTS]] \
- portpkg [list action_target [ACTION_ARGS_PORTS]] \
- rpm [list action_target [ACTION_ARGS_PORTS]] \
- srpm [list action_target [ACTION_ARGS_PORTS]] \
- \
- quit [list action_exit [ACTION_ARGS_NONE]] \
- exit [list action_exit [ACTION_ARGS_NONE]] \
-]
-
-# Expand "action".
-# Returns an action proc, or a list of matching action procs, or the action passed in
-proc find_action { action } {
- global action_array
-
- if { ! [info exists action_array($action)] } {
- set guess [guess_action $action]
- if { [info exists action_array($guess)] } {
- return $guess
- }
- return $guess
- }
-
- return $action
-}
-
-# Expand action
-# If there's more than one match, return the next possibility
-proc find_action_proc { action } {
- global action_array
-
- set action_proc ""
- if { [info exists action_array($action)] } {
- set action_proc [lindex $action_array($action) 0]
- } else {
- set action [complete_action $action]
- if { [info exists action_array($action)] } {
- set action_proc [lindex $action_array($action) 0]
- }
- }
-
- return $action_proc
-}
-
-proc get_action_proc { action } {
- global action_array
-
- set action_proc ""
- if { [info exists action_array($action)] } {
- set action_proc [lindex $action_array($action) 0]
- }
-
- return $action_proc
-}
-
-# Returns whether an action expects text arguments at all,
-# expects text arguments or wants an expanded list of ports
-# Return values are constants:
-# [ACTION_ARGS_NONE] Does not expect any text argument
-# [ACTION_ARGS_STRINGS] Expects some strings as text argument
-# [ACTION_ARGS_PORTS] Wants an expanded list of ports as text argument
-proc action_needs_portlist { action } {
- global action_array
-
- set ret 0
- if {[info exists action_array($action)]} {
- set ret [lindex $action_array($action) 1]
- }
-
- return $ret
-}
-
-# cmd_opts_array specifies which arguments the commands accept
-# Commands not listed here do not accept any arguments
-# Syntax if {option argn}
-# Where option is the name of the option and argn specifies how many arguments
-# this argument takes
-global cmd_opts_array
-array set cmd_opts_array {
- edit {{editor 1}}
- info {category categories depends_fetch depends_extract
- depends_build depends_lib depends_run
- depends description epoch fullname heading homepage index license
- line long_description
- maintainer maintainers name platform platforms portdir pretty
- replaced_by revision subports variant variants version}
- contents {size {units 1}}
- deps {index no-build}
- rdeps {index no-build full}
- rdependents {full}
- search {case-sensitive category categories depends_fetch
- depends_extract depends_build depends_lib depends_run
- depends description epoch exact glob homepage line
- long_description maintainer maintainers name platform
- platforms portdir regex revision variant variants version}
- selfupdate {nosync}
- space {{units 1} total}
- activate {no-exec}
- deactivate {no-exec}
- install {no-rev-upgrade unrequested}
- uninstall {follow-dependents follow-dependencies no-exec}
- variants {index}
- clean {all archive dist work logs}
- mirror {new}
- lint {nitpick}
- select {list set show summary}
- log {{phase 1} {level 1}}
- upgrade {force enforce-variants no-replace no-rev-upgrade}
- rev-upgrade {id-loadcmd-check}
- doctor {quiet}
-}
-
-##
-# Checks whether the given option is valid
-#
-# @param action for which action
-# @param option the prefix of the option to check
-# @return list of pairs {name argc} for all matching options
-proc cmd_option_matches {action option} {
- global cmd_opts_array
-
- # This could be so easy with lsearch -index,
- # but that's only available as of Tcl 8.5
-
- if {![info exists cmd_opts_array($action)]} {
- return {}
- }
-
- set result {}
-
- foreach item $cmd_opts_array($action) {
- if {[llength $item] == 1} {
- set name $item
- set argc 0
- } else {
- set name [lindex $item 0]
- set argc [lindex $item 1]
- }
-
- if {$name == $option} {
- set result [list [list $name $argc]]
- break
- } elseif {[string first $option $name] == 0} {
- lappend result [list $name $argc]
- }
- }
-
- return $result
-}
-
-# Parse global options
-#
-# Note that this is called several times:
-# (1) Initially, to parse options that will be constant across all commands
-# (options that come prior to any command, frozen into global_options_base)
-# (2) Following each command (to parse options that will be unique to that command
-# (the global_options array is reset to global_options_base prior to each command)
-#
-proc parse_options { action ui_options_name global_options_name } {
- upvar $ui_options_name ui_options
- upvar $global_options_name global_options
- global cmdname cmd_opts_array
-
- while {[moreargs]} {
- set arg [lookahead]
-
- if {[string index $arg 0] ne "-"} {
- break
- } elseif {[string index $arg 1] eq "-"} {
- # Process long arguments
- switch -- $arg {
- -- { # This is the options terminator; do no further option processing
- advance; break
- }
- default {
- set key [string range $arg 2 end]
- set kopts [cmd_option_matches $action $key]
- if {[llength $kopts] == 0} {
- return -code error "${action} does not accept --${key}"
- } elseif {[llength $kopts] > 1} {
- set errlst {}
- foreach e $kopts {
- lappend errlst "--[lindex $e 0]"
- }
- return -code error "\"port ${action} --${key}\" is ambiguous: \n port ${action} [join $errlst "\n port ${action} "]"
- }
- set key [lindex $kopts 0 0]
- set kargc [lindex $kopts 0 1]
- if {$kargc == 0} {
- set global_options(ports_${action}_${key}) yes
- } else {
- set args {}
- while {[moreargs] && $kargc > 0} {
- advance
- lappend args [lookahead]
- set kargc [expr {$kargc - 1}]
- }
- if {$kargc > 0} {
- return -code error "--${key} expects [expr {$kargc + [llength $args]}] parameters!"
- }
- set global_options(ports_${action}_${key}) $args
- }
- }
- }
- } else {
- # Process short arg(s)
- set opts [string range $arg 1 end]
- foreach c [split $opts {}] {
- switch -- $c {
- v {
- set ui_options(ports_verbose) yes
- }
- d {
- set ui_options(ports_debug) yes
- # debug implies verbose
- set ui_options(ports_verbose) yes
- }
- q {
- set ui_options(ports_quiet) yes
- }
- p {
- # Ignore errors while processing within a command
- set ui_options(ports_processall) yes
- }
- f {
- set global_options(ports_force) yes
- }
- o {
- set global_options(ports_ignore_different) yes
- }
- n {
- set global_options(ports_nodeps) yes
- }
- u {
- set global_options(port_uninstall_old) yes
- }
- R {
- set global_options(ports_do_dependents) yes
- }
- s {
- set global_options(ports_source_only) yes
- }
- b {
- set global_options(ports_binary_only) yes
- }
- c {
- set global_options(ports_autoclean) yes
- }
- k {
- set global_options(ports_autoclean) no
- }
- t {
- set global_options(ports_trace) yes
- }
- y {
- set global_options(ports_dryrun) yes
- }
- F {
- # Name a command file to process
- advance
- if {[moreargs]} {
- lappend ui_options(ports_commandfiles) [lookahead]
- }
- }
- D {
- advance
- if {[moreargs]} {
- cd [lookahead]
- }
- break
- }
- default {
- print_usage; exit 1
- }
- }
- }
- }
-
- advance
- }
-}
-
-# acquire exclusive registry lock for actions that need it
-# returns 1 if locked, 0 otherwise
-proc lock_reg_if_needed {action} {
- switch -- $action {
- activate -
- deactivate -
- setrequested -
- unsetrequested -
- upgrade -
- uninstall -
- install {
- registry::exclusive_lock
- return 1
- }
- }
- return 0
-}
-
-proc process_cmd { argv } {
- global cmd_argc cmd_argv cmd_argn \
- global_options global_options_base private_options ui_options \
- current_portdir
- set cmd_argv $argv
- set cmd_argc [llength $argv]
- set cmd_argn 0
-
- set action_status 0
-
- # Process an action if there is one
- while {($action_status == 0 || [macports::ui_isset ports_processall]) && [moreargs]} {
- set action [lookahead]
- advance
-
- # Handle command separator
- if { $action == ";" } {
- continue
- }
-
- # Handle a comment
- if { [string index $action 0] == "#" } {
- while { [moreargs] } { advance }
- break
- }
-
- set locked [lock_reg_if_needed $action]
- # Always start out processing an action in current_portdir
- cd $current_portdir
-
- # Reset global_options from base before each action, as we munge it just below...
- array unset global_options
- array set global_options $global_options_base
-
- # Find an action to execute
- set actions [find_action $action]
- if {[llength $actions] == 1} {
- set action [lindex $actions 0]
- set action_proc [get_action_proc $action]
- } else {
- if {[llength $actions] > 1} {
- ui_error "\"port ${action}\" is ambiguous: \n port [join $actions "\n port "]"
- } else {
- ui_error "Unrecognized action \"port $action\""
- }
- set action_status 1
- break
- }
-
- # Parse options that will be unique to this action
- # (to avoid abiguity with -variants and a default port, either -- must be
- # used to terminate option processing, or the pseudo-port current must be specified).
- if {[catch {parse_options $action ui_options global_options} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- ui_error $result
- set action_status 1
- break
- }
-
- # What kind of arguments does the command expect?
- set expand [action_needs_portlist $action]
-
- # Parse action arguments, setting a special flag if there were none
- # We otherwise can't tell the difference between arguments that evaluate
- # to the empty set, and the empty set itself.
- set portlist {}
- switch -- [lookahead] {
- ; -
- _EOF_ {
- set private_options(ports_no_args) yes
- }
- default {
- if {[ACTION_ARGS_NONE] == $expand} {
- ui_error "$action does not accept string arguments"
- set action_status 1
- break
- } elseif {[ACTION_ARGS_STRINGS] == $expand} {
- while { [moreargs] && ![match ";"] } {
- lappend portlist [lookahead]
- advance
- }
- } elseif {[ACTION_ARGS_PORTS] == $expand} {
- # Parse port specifications into portlist
- if {![portExpr portlist]} {
- ui_error "Improper expression syntax while processing parameters"
- set action_status 1
- break
- }
- }
- }
- }
-
- # execute the action
- set action_status [$action_proc $action $portlist [array get global_options]]
-
- # unlock if needed
- if {$locked} {
- registry::exclusive_unlock
- }
-
- # Print notifications of just-activated ports.
- portclient::notifications::display
-
- # semaphore to exit
- if {$action_status == -999} break
- }
-
- return $action_status
-}
-
-
-proc complete_portname { text state } {
- global complete_choices complete_position
-
- if {$state == 0} {
- set complete_position 0
- set complete_choices {}
-
- # Build a list of ports with text as their prefix
- if {[catch {set res [mportsearch "${text}*" false glob]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "search for portname $pattern failed: $result"
- }
- foreach {name info} $res {
- lappend complete_choices $name
- }
- }
-
- set word [lindex $complete_choices $complete_position]
- incr complete_position
-
- return $word
-}
-
-
-# return text action beginning with $text
-proc complete_action { text state } {
- global action_array complete_choices complete_position
-
- if {$state == 0} {
- set complete_position 0
- set complete_choices [array names action_array "[string tolower $text]*"]
- }
-
- set word [lindex $complete_choices $complete_position]
- incr complete_position
-
- return $word
-}
-
-# return all actions beginning with $text
-proc guess_action { text } {
- global action_array
-
- return [array names action_array "[string tolower $text]*"]
-
- if { [llength $complete_choices ] == 1 } {
- return [lindex $complete_choices 0]
- }
-
- return {}
-}
-
-proc attempt_completion { text word start end } {
- # If the word starts with '~', or contains '.' or '/', then use the build-in
- # completion to complete the word
- if { [regexp {^~|[/.]} $word] } {
- return ""
- }
-
- # Decide how to do completion based on where we are in the string
- set prefix [string range $text 0 [expr {$start - 1}]]
-
- # If only whitespace characters preceed us, or if the
- # previous non-whitespace character was a ;, then we're
- # an action (the first word of a command)
- if { [regexp {(^\s*$)|(;\s*$)} $prefix] } {
- return complete_action
- }
-
- # Otherwise, do completion on portname
- return complete_portname
-}
-
-
-proc get_next_cmdline { in out use_readline prompt linename } {
- upvar $linename line
-
- set line ""
- while { $line eq "" } {
-
- if {$use_readline} {
- set len [readline read -attempted_completion attempt_completion line $prompt]
- } else {
- puts -nonewline $out $prompt
- flush $out
- set len [gets $in line]
- }
-
- if { $len < 0 } {
- return -1
- }
-
- set line [string trim $line]
-
- if { $use_readline && $line ne "" } {
- rl_history add $line
- }
- }
-
- return [llength $line]
-}
-
-
-proc process_command_file { in } {
- global current_portdir
-
- # Initialize readline
- set isstdin [string match $in "stdin"]
- set name "port"
- set use_readline [expr {$isstdin && [readline init $name]}]
- set history_file [file normalize "${macports::macports_user_dir}/history"]
-
- # Read readline history
- if {$use_readline && [file isdirectory $macports::macports_user_dir]} {
- rl_history read $history_file
- rl_history stifle 100
- }
-
- # Be noisy, if appropriate
- set noisy [expr $isstdin && ![macports::ui_isset ports_quiet]]
- if { $noisy } {
- puts "MacPorts [macports::version]"
- puts "Entering interactive mode... (\"help\" for help, \"quit\" to quit)"
- }
-
- # Main command loop
- set exit_status 0
- while { $exit_status == 0 || $isstdin || [macports::ui_isset ports_processall] } {
-
- # Calculate our prompt
- if { $noisy } {
- set shortdir [eval file join [lrange [file split $current_portdir] end-1 end]]
- set prompt "\[$shortdir\] > "
- } else {
- set prompt ""
- }
-
- # Get a command line
- if { [get_next_cmdline $in stdout $use_readline $prompt line] <= 0 } {
- puts ""
- break
- }
-
- # Process the command
- set exit_status [process_cmd $line]
-
- # Check for semaphore to exit
- if {$exit_status == -999} {
- set exit_status 0
- break
- }
- }
-
- # Create macports user directory if it does not exist yet
- if {$use_readline && ![file isdirectory $macports::macports_user_dir]} {
- file mkdir $macports::macports_user_dir
- }
- # Save readine history
- if {$use_readline && [file isdirectory $macports::macports_user_dir]} {
- rl_history write $history_file
- }
-
- # Say goodbye
- if { $noisy } {
- puts "Goodbye"
- }
-
- return $exit_status
-}
-
-
-proc process_command_files { filelist } {
- set exit_status 0
-
- # For each file in the command list, process commands
- # in the file
- foreach file $filelist {
- if {$file eq "-"} {
- set in stdin
- } else {
- if {[catch {set in [open $file]} result]} {
- fatal "Failed to open command file; $result"
- }
- }
-
- set exit_status [process_command_file $in]
-
- if {$in ne "stdin"} {
- close $in
- }
-
- # Exit on first failure unless -p was given
- if {$exit_status != 0 && ![macports::ui_isset ports_processall]} {
- return $exit_status
- }
- }
-
- return $exit_status
-}
-
-namespace eval portclient::progress {
- ##
- # Maximum width of the progress bar or indicator when displaying it.
- variable maxWidth 50
-
- ##
- # The start time of the last progress callback as returned by [clock time].
- # Since only one progress indicator is active at a time, this variable is
- # shared between the different variants of progress functions.
- variable startTime
-
- ##
- # Delay in milliseconds after the start of the operation before deciding
- # that showing a progress bar makes sense.
- variable showTimeThreshold 500
-
- ##
- # Percentage value between 0 and 1 that must not have been reached yet when
- # $showTimeThreshold has passed for a progress bar to be shown. If the
- # operation has proceeded above e.g. 75% after 500ms we won't bother
- # displaying a progress indicator anymore -- the operation will be finished
- # in well below a second anyway.
- variable showPercentageThreshold 0.75
-
- ##
- # Boolean indication whether the progress indicator should be shown or is
- # still hidden because the current operation didn't need enough time for
- # a progress indicator to make sense, yet.
- variable show no
-
- ##
- # Initialize the progress bar display delay; call this from the start
- # action of the progress functions.
- proc initDelay {} {
- variable show
- variable startTime
-
- set startTime [clock milliseconds]
- set show no
- }
-
- ##
- # Determine whether a progress bar should be shown for the current
- # operation in its current state. You must have called initDelay for the
- # current operation before calling this method.
- #
- # @param cur
- # Current progress in abstract units.
- # @param total
- # Total number of abstract units to be processed, if known. Pass
- # 0 if unknown.
- # @return
- # "yes", if the progress indicator should be shown, "no" otherwise.
- proc showProgress {cur total} {
- variable show
- variable startTime
- variable showTimeThreshold
- variable showPercentageThreshold
-
- if {$show eq "yes"} {
- return yes
- } else {
- if {[expr {[clock milliseconds] - $startTime}] > $showTimeThreshold &&
- ($total == 0 || [expr {double($cur) / double($total)}] < $showPercentageThreshold)} {
- set show yes
- }
- return $show
- }
- }
-
- ##
- # Progress callback for generic operations executed by macports 1.0.
- #
- # @param action
- # One of "start", "update", "intermission" or "finish", where start
- # will be called before any number of update calls, interrupted by
- # any number of intermission calls (called because other output is
- # being produced), followed by one call to finish.
- # @param args
- # A list of variadic args that differ for each action. For "start",
- # "intermission" and "finish", the args are empty and unused. For
- # "update", args contains $cur and $total, where $cur is the current
- # number of units processed and $total is the total number of units
- # to be processed. If the total is not known, it is 0.
- proc generic {action args} {
- global env
- variable maxWidth
-
- switch -nocase -- $action {
- start {
- initDelay
- }
- update {
- # the for loop is a simple hack because Tcl 8.4 doesn't have
- # lassign
- foreach {now total} $args {
- if {[showProgress $now $total] eq "yes"} {
- set barPrefix " "
- set barPrefixLen [string length $barPrefix]
- if {$total != 0} {
- progressbar $now $total [expr {min($maxWidth, $env(COLUMNS) - $barPrefixLen)}] $barPrefix
- } else {
- unprogressbar [expr {min($maxWidth, $env(COLUMNS) - $barPrefixLen)}] $barPrefix
- }
- }
- }
- }
- intermission -
- finish {
- # erase to start of line
- ::term::ansi::send::esol
- # return cursor to start of line
- puts -nonewline "\r"
- flush stdout
- }
- }
-
- return 0
- }
-
- ##
- # Progress callback for downloads executed by macports 1.0.
- #
- # This is essentially a cURL progress callback.
- #
- # @param action
- # One of "start", "update" or "finish", where start will be called
- # before any number of update calls, followed by one call to finish.
- # @param args
- # A list of variadic args that differ for each action. For "start",
- # contains a single argument "ul" or "dl" indicating whether this is
- # an up- or download. For "update", contains the arguments
- # ("ul"|"dl") $total $now $speed where ul/dl are as for start, and
- # total, now and speed are doubles indicating the total transfer
- # size, currently transferred amount and average speed per second in
- # bytes. Unused for "finish".
- proc download {action args} {
- global env
- variable maxWidth
-
- switch -nocase -- $action {
- start {
- initDelay
- }
- update {
- # the for loop is a simple hack because Tcl 8.4 doesn't have
- # lassign
- foreach {type total now speed} $args {
- if {[showProgress $now $total] eq "yes"} {
- set barPrefix " "
- set barPrefixLen [string length $barPrefix]
- if {$total != 0} {
- set barSuffix [format " speed: %-13s" "[bytesize $speed {} "%.1f"]/s"]
- set barSuffixLen [string length $barSuffix]
-
- set barLen [expr {min($maxWidth, $env(COLUMNS) - $barPrefixLen - $barSuffixLen)}]
- progressbar $now $total $barLen $barPrefix $barSuffix
- } else {
- set barSuffix [format " %-10s speed: %-13s" [bytesize $now {} "%6.1f"] "[bytesize $speed {} "%.1f"]/s"]
- set barSuffixLen [string length $barSuffix]
-
- set barLen [expr {min($maxWidth, $env(COLUMNS) - $barPrefixLen - $barSuffixLen)}]
- unprogressbar $barLen $barPrefix $barSuffix
- }
- }
- }
- }
- finish {
- # erase to start of line
- ::term::ansi::send::esol
- # return cursor to start of line
- puts -nonewline "\r"
- flush stdout
- }
- }
-
- return 0
- }
-
- ##
- # Draw a progress bar using unicode block drawing characters
- #
- # @param current
- # The current progress value.
- # @param total
- # The progress value representing 100%.
- # @param width
- # The width in characters of the progress bar. This includes percentage
- # output, which takes up 8 characters.
- # @param prefix
- # Prefix to be printed in front of the progress bar.
- # @param suffix
- # Suffix to be printed after the progress bar.
- proc progressbar {current total width {prefix ""} {suffix ""}} {
- # Subtract the width of the percentage output, also subtract the two
- # characters [ and ] bounding the progress bar.
- set percentageWidth 8
- set barWidth [expr {entier($width) - $percentageWidth - 2}]
-
- # Map the range (0, $total) to (0, 4 * $width) where $width is the maximum
- # numebr of characters to be printed for the progress bar. Multiply the
- # upper bound with 8 because we have 8 sub-states per character.
- set barProgress [expr {entier(round(($current * $barWidth * 8) / $total))}]
-
- set barInteger [expr {$barProgress / 8}]
- #set barRemainder [expr {$barProgress % 8}]
-
- # Finally, also provide a percentage value to print behind the progress bar
- set percentage [expr {double($current) * 100 / double($total)}]
-
- # clear the current line, enable reverse video
- set progressbar "\033\[7m"
- for {set i 0} {$i < $barInteger} {incr i} {
- # U+2588 FULL BLOCK doesn't match the other blocks in some fonts :/
- # Two half blocks work better in some fonts, but not in others (because
- # they leave ugly spaces). So, one or the other choice isn't better or
- # worse and even just using full blocks looks ugly in a few fonts.
-
- # Use pure ASCII until somebody fixes most of the default terminal fonts :/
- append progressbar " "
- }
- # back to normal output
- append progressbar "\033\[0m"
-
- #switch $barRemainder {
- # 0 {
- # if {$barInteger < $barWidth} {
- # append progressbar " "
- # }
- # }
- # 1 {
- # # U+258F LEFT ONE EIGHTH BLOCK
- # append progressbar "\u258f"
- # }
- # 2 {
- # # U+258E LEFT ONE QUARTER BLOCK
- # append progressbar "\u258e"
- # }
- # 3 {
- # # U+258D LEFT THREE EIGHTHS BLOCK
- # append progressbar "\u258d"
- # }
- # 3 {
- # # U+258D LEFT THREE EIGHTHS BLOCK
- # append progressbar "\u258d"
- # }
- # 4 {
- # # U+258C LEFT HALF BLOCK
- # append progressbar "\u258c"
- # }
- # 5 {
- # # U+258B LEFT FIVE EIGHTHS BLOCK
- # append progressbar "\u258b"
- # }
- # 6 {
- # # U+258A LEFT THREE QUARTERS BLOCK
- # append progressbar "\u258a"
- # }
- # 7 {
- # # U+2589 LEFT SEVEN EIGHTHS BLOCK
- # append progressbar "\u2589"
- # }
- #}
-
- # Fill the progress bar with spaces
- for {set i $barInteger} {$i < $barWidth} {incr i} {
- append progressbar " "
- }
-
- # Format the percentage using the space that has been reserved for it
- set percentagesuffix [format " %[expr {$percentageWidth - 3}].1f %%" $percentage]
-
- puts -nonewline "\r${prefix}\[${progressbar}\]${percentagesuffix}${suffix}"
- flush stdout
- }
-
-
- ##
- # Internal state of the progress indicator; unless you're hacking the
- # unprogressbar code you should never touch this.
- variable unprogressState 0
-
- ##
- # Draw a progress indicator
- #
- # @param width
- # The width in characters of the progress indicator.
- # @param prefix
- # Prefix to be printed in front of the progress indicator.
- # @param suffix
- # Suffix to be printed after the progress indicator.
- proc unprogressbar {width {prefix ""} {suffix ""}} {
- variable unprogressState
-
- # Subtract the two characters [ and ] bounding the progress indicator
- # from the width.
- set barWidth [expr {int($width) - 2}]
-
- # Number of states of the progress bar, or rather: the number of
- # characters before the sequence repeats.
- set numStates 4
-
- set unprogressState [expr {($unprogressState + 1) % $numStates}]
-
- set progressbar ""
- for {set i 0} {$i < $barWidth} {incr i} {
- if {[expr {$i % $numStates}] == $unprogressState} {
- # U+2022 BULLET
- append progressbar "\u2022"
- } else {
- append progressbar " "
- }
- }
-
- puts -nonewline "\r${prefix}\[${progressbar}\]${suffix}"
- flush stdout
- }
-}
-
-namespace eval portclient::notifications {
- ##
- # Ports whose notifications to display; these were either installed
- # or requested to be installed.
- variable notificationsToPrint
- array set notificationsToPrint {}
-
- ##
- # Add a port to the list for printing notifications.
- #
- # @param name
- # The name of the port.
- # @param note
- # A list of notes to be stored for the given port.
- proc append {name notes} {
- variable notificationsToPrint
-
- set notificationsToPrint($name) $notes
- }
-
- ##
- # Print port notifications.
- #
- proc display {} {
- global env
- variable notificationsToPrint
-
- # Display notes at the end of the activation phase.
- if {[array size notificationsToPrint] > 0} {
- ui_notice "---> Some of the ports you installed have notes:"
- foreach {name notes} [array get notificationsToPrint] {
- ui_notice " $name has the following notes:"
-
- # If env(COLUMNS) exists, limit each line's width to this width.
- if {[info exists env(COLUMNS)]} {
- set maxlen $env(COLUMNS)
-
- foreach note $notes {
- foreach line [split $note "\n"] {
- set joiner ""
- set lines ""
- set newline " "
-
- foreach word [split $line " "] {
- if {[string length $newline] + [string length $word] >= $maxlen} {
- lappend lines $newline
- set newline " "
- set joiner ""
- }
- ::append newline $joiner $word
- set joiner " "
- }
- if {$newline ne {}} {
- lappend lines $newline
- }
- ui_notice [join $lines "\n"]
- }
- }
- } else {
- foreach note $notes {
- ui_notice $note
- }
- }
- }
- }
- }
-}
-
-
-##########################################
-# Main
-##########################################
-
-# Global arrays passed to the macports1.0 layer
-array set ui_options {}
-array set global_options {}
-array set global_variations {}
-
-# Global options private to this script
-array set private_options {}
-
-# Make sure we get the size of the terminal
-# We do this here to save it in the boot_env, in case we determined it manually
-term_init_size
-
-global env boot_env argv0 cmdname argc argv cmd_argc cmd_argv cmd_argn \
- current_portdir global_options_base exit_status
-
-# Save off a copy of the environment before mportinit monkeys with it
-array set boot_env [array get env]
-
-set cmdname [file tail $argv0]
-
-# Setp cmd_argv to match argv
-set cmd_argv $argv
-set cmd_argc $argc
-set cmd_argn 0
-
-# make sure we're using a sane umask
-umask 022
-
-# If we've been invoked as portf, then the first argument is assumed
-# to be the name of a command file (i.e., there is an implicit -F
-# before any arguments).
-if {[moreargs] && $cmdname eq "portf"} {
- lappend ui_options(ports_commandfiles) [lookahead]
- advance
-}
-
-# Parse global options that will affect all subsequent commands
-if {[catch {parse_options "global" ui_options global_options} result]} {
- puts "Error: $result"
- print_usage
- exit 1
-}
-
-if {[isatty stdout]
- && $portclient::progress::hasTermAnsiSend eq "yes"
- && (![info exists ui_options(ports_quiet)] || $ui_options(ports_quiet) ne "yes")} {
- set ui_options(progress_download) portclient::progress::download
- set ui_options(progress_generic) portclient::progress::generic
-}
-
-set ui_options(notifications_append) portclient::notifications::append
-
-# Get arguments remaining after option processing
-set remaining_args [lrange $cmd_argv $cmd_argn end]
-
-# If we have no arguments remaining after option processing then force
-# interactive mode
-if { [llength $remaining_args] == 0 && ![info exists ui_options(ports_commandfiles)] } {
- lappend ui_options(ports_commandfiles) -
-} elseif {[lookahead] eq "selfupdate" || [lookahead] eq "sync"} {
- # tell mportinit not to tell the user they should selfupdate
- set ui_options(ports_no_old_index_warning) 1
-}
-
-# Initialize mport
-# This must be done following parse of global options, as some options are
-# evaluated by mportinit.
-if {[catch {mportinit ui_options global_options global_variations} result]} {
- global errorInfo
- puts "$errorInfo"
- fatal "Failed to initialize MacPorts, $result"
-}
-
-# Set up some global state for our code
-set current_portdir [pwd]
-
-# Freeze global_options into global_options_base; global_options
-# will be reset to global_options_base prior to processing each command.
-set global_options_base [array get global_options]
-
-# First process any remaining args as action(s)
-set exit_status 0
-if { [llength $remaining_args] > 0 } {
-
- # If there are remaining arguments, process those as a command
- set exit_status [process_cmd $remaining_args]
-}
-
-# Process any prescribed command files, including standard input
-if { ($exit_status == 0 || [macports::ui_isset ports_processall]) && [info exists ui_options(ports_commandfiles)] } {
- set exit_status [process_command_files $ui_options(ports_commandfiles)]
-}
-if {$exit_status == -999} {
- set exit_status 0
-}
-
-# shut down macports1.0
-mportshutdown
-
-# Return with exit_status
-exit $exit_status
Deleted: branches/gsoc14-cleanup/src/port/port.orig
===================================================================
--- branches/gsoc14-cleanup/src/port/port.orig 2014-08-13 22:14:51 UTC (rev 123747)
+++ branches/gsoc14-cleanup/src/port/port.orig 2014-08-13 22:14:53 UTC (rev 123748)
@@ -1,5362 +0,0 @@
-#!/opt/local/libexec/macports/bin/tclsh8.5
-# -*- coding: utf-8; mode: tcl; tab-width: 4; indent-tabs-mode: nil; c-basic-offset: 4 -*- vim:fenc=utf-8:filetype=tcl:et:sw=4:ts=4:sts=4
-# $Id: port.tcl 119177 2014-04-18 22:35:29Z cal at macports.org $
-#
-# Copyright (c) 2004-2014 The MacPorts Project
-# Copyright (c) 2004 Robert Shaw <rshaw at opendarwin.org>
-# Copyright (c) 2002-2003 Apple 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 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.
-
-# Create a namespace for some local variables
-namespace eval portclient::progress {
- ##
- # Indicate whether the term::ansi::send tcllib package is available and was
- # imported. "yes", if the package is available, "no" otherwise.
- variable hasTermAnsiSend no
-}
-
-if {![catch {package require term::ansi::send}]} {
- set portclient::progress::hasTermAnsiSend yes
-}
-
-package require macports
-package require Pextlib 1.0
-
-# Standard procedures
-proc print_usage {{verbose 1}} {
- global cmdname
- set syntax {
- [-bcdfknopqRstuvy] [-D portdir] [-F cmdfile] action [privopts] [actionflags]
- [[portname|pseudo-portname|port-url] [@version] [+-variant]... [option=value]...]...
- }
-
- if {$verbose} {
- puts stderr "Usage: $cmdname$syntax"
- puts stderr "\"$cmdname help\" or \"man 1 port\" for more information."
- } else {
- puts stderr "$cmdname$syntax"
- }
-}
-
-proc print_help {args} {
- global action_array
-
- print_usage 0
-
- # Generate and format the command list from the action_array
- set cmds ""
- set lineLen 0
- foreach cmd [lsort [array names action_array]] {
- if {$lineLen > 65} {
- set cmds "$cmds,\n"
- set lineLen 0
- }
- if {$lineLen == 0} {
- set new "$cmd"
- } else {
- set new ", $cmd"
- }
- incr lineLen [string length $new]
- set cmds "$cmds$new"
- }
-
- set cmdText "Supported actions
-------------------
-$cmds
-"
-
- set text {
-Pseudo-portnames
-----------------
-Pseudo-portnames are words that may be used in place of a portname, and
-which expand to some set of ports. The common pseudo-portnames are:
-all, current, active, inactive, actinact, installed, uninstalled, outdated,
-obsolete, requested, unrequested and leaves.
-These pseudo-portnames expand to the set of ports named.
-
-Pseudo-portnames starting with variants:, variant:, description:, depends:,
-depends_lib:, depends_run:, depends_build:, depends_fetch:, depends_extract:,
-portdir:, homepage:, epoch:, platforms:, platform:, name:, long_description:,
-maintainers:, maintainer:, categories:, category:, version:, revision:, and
-license: each select a set of ports based on a regex search of metadata
-about the ports. In all such cases, a standard regex pattern following
-the colon will be used to select the set of ports to which the
-pseudo-portname expands.
-
-Pseudo-portnames starting with depof:, rdepof:, dependentof:, and rdependentof:
-select ports that are direct or recursive dependencies or dependents of the
-following portname, respectively.
-
-Portnames that contain standard glob characters will be expanded to the
-set of ports matching the glob pattern.
-
-Port expressions
-----------------
-Portnames, port glob patterns, and pseudo-portnames may be logically
-combined using expressions consisting of and, or, not, !, (, and ).
-
-For more information
---------------------
-See man pages: port(1), macports.conf(5), portfile(7), portgroup(7),
-porthier(7), portstyle(7). Also, see http://www.macports.org.
- }
-
- puts "$cmdText$text"
-}
-
-
-# Produce error message and exit
-proc fatal s {
- global argv0
- ui_error "$argv0: $s"
- exit 1
-}
-
-##
-# Helper function to define constants
-#
-# Constants defined with const can simply be accessed in the same way as
-# calling a proc.
-#
-# Example:
-# const FOO 42
-# puts [FOO]
-#
-# @param name variable name
-# @param value constant variable value
-proc const {name args} {
- proc $name {} [list return [expr $args]]
-}
-
-# Format an integer representing bytes using given units
-proc bytesize {siz {unit {}} {format {%.3f}}} {
- if {$unit == {}} {
- if {$siz > 0x40000000} {
- set unit "GiB"
- } elseif {$siz > 0x100000} {
- set unit "MiB"
- } elseif {$siz > 0x400} {
- set unit "KiB"
- } else {
- set unit "B"
- }
- }
- switch -- $unit {
- KiB {
- set siz [expr {$siz / 1024.0}]
- }
- kB {
- set siz [expr {$siz / 1000.0}]
- }
- MiB {
- set siz [expr {$siz / 1048576.0}]
- }
- MB {
- set siz [expr {$siz / 1000000.0}]
- }
- GiB {
- set siz [expr {$siz / 1073741824.0}]
- }
- GB {
- set siz [expr {$siz / 1000000000.0}]
- }
- B { }
- default {
- ui_warn "Unknown file size unit '$unit' specified"
- set unit "B"
- }
- }
- if {[expr {round($siz)}] != $siz} {
- set siz [format $format $siz]
- }
- return "$siz $unit"
-}
-
-proc filesize {fil {unit {}}} {
- set siz {@}
- catch {
- set siz [bytesize [file size $fil] $unit]
- }
- return $siz
-}
-
-# Produce an error message, and exit, unless
-# we're handling errors in a soft fashion, in which
-# case we continue
-proc fatal_softcontinue s {
- if {[macports::global_option_isset ports_force]} {
- ui_error $s
- return -code continue
- } else {
- fatal $s
- }
-}
-
-
-# Produce an error message, and break, unless
-# we're handling errors in a soft fashion, in which
-# case we continue
-proc break_softcontinue { msg status name_status } {
- upvar $name_status status_var
- ui_error $msg
- if {[macports::ui_isset ports_processall]} {
- set status_var 0
- return -code continue
- } else {
- set status_var $status
- return -code break
- }
-}
-
-# show the URL for the ticket reporting instructions
-proc print_tickets_url {args} {
- if {${macports::prefix} ne "/usr/local" && ${macports::prefix} ne "/usr"} {
- ui_error "Follow http://guide.macports.org/#project.tickets to report a bug."
- }
-}
-
-# Form a composite version as is sometimes used for registry functions
-# This function sorts the variants and presents them in a canonical representation
-proc composite_version {version variations {emptyVersionOkay 0}} {
- # Form a composite version out of the version and variations
-
- # Select the variations into positive and negative
- set pos {}
- set neg {}
- foreach { key val } $variations {
- if {$val eq "+"} {
- lappend pos $key
- } elseif {$val eq "-"} {
- lappend neg $key
- }
- }
-
- # If there is no version, we have nothing to do
- set composite_version ""
- if {$version ne "" || $emptyVersionOkay} {
- set pos_str ""
- set neg_str ""
-
- if {[llength $pos]} {
- set pos_str "+[join [lsort -ascii $pos] "+"]"
- }
- if {[llength $neg]} {
- set neg_str "-[join [lsort -ascii $neg] "-"]"
- }
-
- set composite_version "$version$pos_str$neg_str"
- }
-
- return $composite_version
-}
-
-
-proc split_variants {variants} {
- set result {}
- set l [regexp -all -inline -- {([-+])([[:alpha:]_]+[\w\.]*)} $variants]
- foreach { match sign variant } $l {
- lappend result $variant $sign
- }
- return $result
-}
-
-
-##
-# Maps friendly field names to their real name
-# Names which do not need mapping are not changed.
-#
-# @param field friendly name
-# @return real name
-proc map_friendly_field_names { field } {
- switch -- $field {
- variant -
- platform -
- maintainer -
- subport {
- set field "${field}s"
- }
- category {
- set field "categories"
- }
- }
-
- return $field
-}
-
-
-proc registry_installed {portname {portversion ""}} {
- set ilist [registry::installed $portname $portversion]
- if { [llength $ilist] > 1 } {
- # set portname again since the one we were passed may not have had the correct case
- set portname [lindex $ilist 0 0]
- ui_notice "The following versions of $portname are currently installed:"
- foreach i [portlist_sortint $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 -code error "Registry error: Please specify the full version as recorded in the port registry."
- } else {
- return [lindex $ilist 0]
- }
-}
-
-
-proc entry_for_portlist {portentry} {
- global global_options global_variations
-
- # Each portlist entry currently has the following elements in it:
- # url if any
- # name
- # version (version_revision)
- # variants array (variant=>+-)
- # requested_variants array (variant=>+-)
- # options array (key=>value)
- # fullname (name/version_revision+-variants)
-
- array set port $portentry
- if {![info exists port(url)]} { set port(url) "" }
- if {![info exists port(name)]} { set port(name) "" }
- if {![info exists port(version)]} { set port(version) "" }
- if {![info exists port(variants)]} { set port(variants) "" }
- if {![info exists port(requested_variants)]} { set port(requested_variants) "" }
- if {![info exists port(options)]} { set port(options) [array get global_options] }
-
- # If neither portname nor url is specified, then default to the current port
- if { $port(url) eq "" && $port(name) eq "" } {
- set url file://.
- set portname [url_to_portname $url]
- set port(url) $url
- set port(name) $portname
- if {$portname eq ""} {
- ui_error "A default port name could not be supplied."
- }
- }
-
- # Form the fully discriminated portname: portname/version_revison+-variants
- set port(fullname) "$port(name)/[composite_version $port(version) $port(variants)]"
-
- return [array get port]
-}
-
-
-proc add_to_portlist {listname portentry} {
- upvar $listname portlist
-
- # Form portlist entry and add to portlist
- lappend portlist [entry_for_portlist $portentry]
-}
-
-
-proc add_ports_to_portlist {listname ports {overridelist ""}} {
- upvar $listname portlist
-
- array set overrides $overridelist
-
- # Add each entry to the named portlist, overriding any values
- # specified as overrides
- foreach portentry $ports {
- array set port $portentry
- if ([info exists overrides(version)]) { set port(version) $overrides(version) }
- if ([info exists overrides(variants)]) { set port(variants) $overrides(variants) }
- if ([info exists overrides(requested_variants)]) { set port(requested_variants) $overrides(requested_variants) }
- if ([info exists overrides(options)]) { set port(options) $overrides(options) }
- add_to_portlist portlist [array get port]
- }
-}
-
-
-proc url_to_portname { url {quiet 0} } {
- # Save directory and restore the directory, since mportopen changes it
- set savedir [pwd]
- set portname ""
- if {[catch {set ctx [mportopen $url]} result]} {
- if {!$quiet} {
- ui_msg "Can't map the URL '$url' to a port description file (\"${result}\")."
- ui_msg "Please verify that the directory and portfile syntax are correct."
- }
- } else {
- array set portinfo [mportinfo $ctx]
- set portname $portinfo(name)
- mportclose $ctx
- }
- cd $savedir
- return $portname
-}
-
-
-# Supply a default porturl/portname if the portlist is empty
-proc require_portlist { nameportlist {is_upgrade "no"} } {
- global private_options
- upvar $nameportlist portlist
-
- if {[llength $portlist] == 0 && (![info exists private_options(ports_no_args)] || $private_options(ports_no_args) eq "no")} {
- if {${is_upgrade} == "yes"} {
- # $> port upgrade outdated
- # Error: No ports matched the given expression
- # is not very user friendly - if we're in the special case of
- # "upgrade", let's print a message that's a little easier to
- # understand and less alarming.
- ui_msg "Nothing to upgrade."
- return 1
- }
- ui_error "No ports matched the given expression"
- return 1
- }
-
- if {[llength $portlist] == 0} {
- set portlist [get_current_port]
-
- if {[llength $portlist] == 0} {
- # there was no port in current directory
- return 1
- }
- }
-
- return 0
-}
-
-
-# Execute the enclosed block once for every element in the portlist
-# When the block is entered, the following variables will have been set:
-# portspec, porturl, portname, portversion, options, variations, requested_variations
-proc foreachport {portlist block} {
- set savedir [pwd]
- foreach portspec $portlist {
-
- # Set the variables for the block
- uplevel 1 "array unset portspec; array set portspec { $portspec }"
- uplevel 1 {
- set porturl $portspec(url)
- set portname $portspec(name)
- set portversion $portspec(version)
- array unset variations
- array set variations $portspec(variants)
- array unset requested_variations
- array set requested_variations $portspec(requested_variants)
- array unset options
- array set options $portspec(options)
- }
-
- # Invoke block
- uplevel 1 $block
-
- # Restore cwd after each port, since mportopen changes it, and otherwise relative
- # urls would break on subsequent passes
- if {[file exists $savedir]} {
- cd $savedir
- } else {
- cd ~
- }
- }
-}
-
-
-proc portlist_compare { a b } {
- array set a_ $a
- array set b_ $b
- set namecmp [string equal -nocase $a_(name) $b_(name)]
- if {$namecmp != 1} {
- if {$a_(name) eq [lindex [lsort -dictionary [list $a_(name) $b_(name)]] 0]} {
- return -1
- }
- return 1
- }
- set avr_ [split $a_(version) "_"]
- set bvr_ [split $b_(version) "_"]
- set versioncmp [vercmp [lindex $avr_ 0] [lindex $bvr_ 0]]
- if {$versioncmp != 0} {
- return $versioncmp
- }
- set ar_ [lindex $avr_ 1]
- set br_ [lindex $bvr_ 1]
- if {$ar_ < $br_} {
- return -1
- } elseif {$ar_ > $br_} {
- return 1
- } else {
- return 0
- }
-}
-
-# Sort two ports in NVR (name at version_revision) order
-proc portlist_sort { list } {
- return [lsort -command portlist_compare $list]
-}
-
-proc portlist_compareint { a b } {
- array set a_ [list "name" [lindex $a 0] "version" "[lindex $a 1]_[lindex $a 2]"]
- array set b_ [list "name" [lindex $b 0] "version" "[lindex $b 1]_[lindex $b 2]"]
- return [portlist_compare [array get a_] [array get b_]]
-}
-
-# Same as portlist_sort, but with numeric indexes {name version revision}
-proc portlist_sortint { list } {
- return [lsort -command portlist_compareint $list]
-}
-
-# sort portlist so dependents come before their dependencies
-proc portlist_sortdependents { portlist } {
- foreach p $portlist {
- array set pvals $p
- lappend entries($pvals(name)) $p
- if {![info exists dependents($pvals(name))]} {
- set dependents($pvals(name)) {}
- foreach result [registry::list_dependents $pvals(name)] {
- lappend dependents($pvals(name)) [lindex $result 2]
- }
- }
- array unset pvals
- }
- set ret {}
- foreach p $portlist {
- portlist_sortdependents_helper $p entries dependents seen ret
- }
- return $ret
-}
-
-proc portlist_sortdependents_helper {p up_entries up_dependents up_seen up_retlist} {
- upvar $up_seen seen
- if {![info exists seen($p)]} {
- set seen($p) 1
- upvar $up_entries entries $up_dependents dependents $up_retlist retlist
- array set pvals $p
- foreach dependent $dependents($pvals(name)) {
- if {[info exists entries($dependent)]} {
- foreach entry $entries($dependent) {
- portlist_sortdependents_helper $entry entries dependents seen retlist
- }
- }
- }
- lappend retlist $p
- }
-}
-
-proc regex_pat_sanitize { s } {
- set sanitized [regsub -all {[\\(){}+$.^]} $s {\\&}]
- return $sanitized
-}
-
-##
-# Makes sure we get the current terminal size
-proc term_init_size {} {
- global env
-
- if {![info exists env(COLUMNS)] || ![info exists env(LINES)]} {
- if {[isatty stdout]} {
- set size [term_get_size stdout]
-
- if {![info exists env(LINES)] && [lindex $size 0] > 0} {
- set env(LINES) [lindex $size 0]
- }
-
- if {![info exists env(COLUMNS)] && [lindex $size 1] > 0} {
- set env(COLUMNS) [lindex $size 1]
- }
- }
- }
-}
-
-##
-# Wraps a multi-line string at specified textwidth
-#
-# @see wrapline
-#
-# @param string input string
-# @param maxlen text width (0 defaults to current terminal width)
-# @param indent prepend to every line
-# @return wrapped string
-proc wrap {string maxlen {indent ""} {indentfirstline 1}} {
- global env
-
- if {$maxlen == 0} {
- if {![info exists env(COLUMNS)]} {
- # no width for wrapping
- return $string
- }
- set maxlen $env(COLUMNS)
- }
-
- set splitstring {}
- set indentline $indentfirstline
- foreach line [split $string "\n"] {
- lappend splitstring [wrapline $line $maxlen $indent $indentline]
- set indentline 1
- }
- return [join $splitstring "\n"]
-}
-
-##
-# Wraps a line at specified textwidth
-#
-# @see wrap
-#
-# @param line input line
-# @param maxlen text width (0 defaults to current terminal width)
-# @param indent prepend to every line
-# @return wrapped string
-proc wrapline {line maxlen {indent ""} {indentfirstline 1}} {
- global env
-
- if {$maxlen == 0} {
- if {![info exists env(COLUMNS)]} {
- # no width for wrapping
- return $string
- }
- set maxlen $env(COLUMNS)
- }
-
- set string [split $line " "]
- if {$indentfirstline == 0} {
- set newline ""
- set maxlen [expr {$maxlen - [string length $indent]}]
- } else {
- set newline $indent
- }
- append newline [lindex $string 0]
- set joiner " "
- set first 1
- foreach word [lrange $string 1 end] {
- if {[string length $newline]+[string length $word] >= $maxlen} {
- lappend lines $newline
- set newline $indent
- set joiner ""
- # If indentfirstline is set to 0, reset maxlen to its
- # original length after appending the first line to lines.
- if {$first == 1 && $indentfirstline == 0} {
- set maxlen [expr {$maxlen + [string length $indent]}]
- }
- set first 0
- }
- append newline $joiner $word
- set joiner " "
- }
- lappend lines $newline
- return [join $lines "\n"]
-}
-
-##
-# Wraps a line at a specified width with a label in front
-#
-# @see wrap
-#
-# @param label label for output
-# @param string input string
-# @param maxlen text width (0 defaults to current terminal width)
-# @return wrapped string
-proc wraplabel {label string maxlen {indent ""}} {
- append label ": [string repeat " " [expr {[string length $indent] - [string length "$label: "]}]]"
- return "$label[wrap $string $maxlen $indent 0]"
-}
-
-proc unobscure_maintainers { list } {
- set result {}
- foreach m $list {
- if {[string first "@" $m] < 0} {
- if {[string first ":" $m] >= 0} {
- set m [regsub -- "(.*):(.*)" $m "\\2@\\1"]
- } else {
- set m "$m at macports.org"
- }
- }
- lappend result $m
- }
- return $result
-}
-
-
-##########################################
-# Port selection
-##########################################
-proc unique_results_to_portlist {infos} {
- set result {}
- array unset unique
- foreach {name info} $infos {
- array unset portinfo
- array set portinfo $info
-
- set portentry [entry_for_portlist [list url $portinfo(porturl) name $name]]
-
- array unset entry
- array set entry $portentry
-
- if {[info exists unique($entry(fullname))]} continue
- set unique($entry(fullname)) 1
-
- lappend result $portentry
- }
- return $result
-}
-
-
-proc get_matching_ports {pattern {casesensitive no} {matchstyle glob} {field name}} {
- if {[catch {set res [mportsearch $pattern $casesensitive $matchstyle $field]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "search for portname $pattern failed: $result"
- }
- set results [unique_results_to_portlist $res]
-
- # Return the list of all ports, sorted
- return [portlist_sort $results]
-}
-
-
-proc get_all_ports {} {
- global all_ports_cache
-
- if {![info exists all_ports_cache]} {
- if {[catch {set res [mportlistall]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "listing all ports failed: $result"
- }
- set results [unique_results_to_portlist $res]
- set all_ports_cache [portlist_sort $results]
- }
- return $all_ports_cache
-}
-
-
-proc get_current_ports {} {
- # This is just a synonym for get_current_port that
- # works with the regex in element
- return [get_current_port]
-}
-
-
-proc get_current_port {} {
- set url file://.
- set portname [url_to_portname $url]
- if {$portname eq ""} {
- ui_msg "To use the current port, you must be in a port's directory."
- return [list]
- }
-
- set results {}
- add_to_portlist results [list url $url name $portname]
- return $results
-}
-
-
-proc get_installed_ports { {ignore_active yes} {active yes} } {
- set ilist {}
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "port installed failed: $result"
- }
- }
-
- set results {}
- foreach i $ilist {
- set iname [lindex $i 0]
- set iversion [lindex $i 1]
- set irevision [lindex $i 2]
- set ivariants [split_variants [lindex $i 3]]
- set iactive [lindex $i 4]
-
- if { ${ignore_active} == "yes" || (${active} == "yes") == (${iactive} != 0) } {
- add_to_portlist results [list name $iname version "${iversion}_${irevision}" variants $ivariants]
- }
- }
-
- # Return the list of ports, sorted
- return [portlist_sort $results]
-}
-
-
-proc get_uninstalled_ports {} {
- # Return all - installed
- set all [get_all_ports]
- set installed [get_installed_ports]
- return [opComplement $all $installed]
-}
-
-
-proc get_active_ports {} {
- return [get_installed_ports no yes]
-}
-
-
-proc get_inactive_ports {} {
- return [get_installed_ports no no]
-}
-
-proc get_actinact_ports {} {
- set inactive_ports [get_inactive_ports]
- set active_ports [get_active_ports]
- set results {}
-
- foreach port $inactive_ports {
- array set portspec $port
- set portname $portspec(name)
- lappend inact($portname) $port
- }
-
- foreach port $active_ports {
- array set portspec $port
- set portname $portspec(name)
-
- if {[info exists inact($portname)]} {
- if {![info exists added_inact($portname)]} {
- foreach inact_spec $inact($portname) {
- lappend results $inact_spec
- }
- set added_inact($portname) 1
- }
- lappend results $port
- }
- }
- return $results
-}
-
-
-proc get_outdated_ports {} {
- # Get the list of installed ports
- set ilist {}
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "port installed failed: $result"
- }
- }
-
- # Now process the list, keeping only those ports that are outdated
- set results {}
- if { [llength $ilist] > 0 } {
- foreach i $ilist {
-
- # Get information about the installed port
- set portname [lindex $i 0]
- set installed_version [lindex $i 1]
- set installed_revision [lindex $i 2]
- set installed_compound "${installed_version}_${installed_revision}"
- set installed_variants [lindex $i 3]
-
- set is_active [lindex $i 4]
- if {$is_active == 0} continue
-
- set installed_epoch [lindex $i 5]
-
- # Get info about the port from the index
- if {[catch {set res [mportlookup $portname]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "lookup of portname $portname failed: $result"
- }
- if {[llength $res] < 2} {
- if {[macports::ui_isset ports_debug]} {
- puts stderr "$portname ($installed_compound is installed; the port was not found in the port index)"
- }
- continue
- }
- array unset portinfo
- array set portinfo [lindex $res 1]
-
- # Get information about latest available version and revision
- set latest_version $portinfo(version)
- set latest_revision 0
- if {[info exists portinfo(revision)] && $portinfo(revision) > 0} {
- set latest_revision $portinfo(revision)
- }
- set latest_compound "${latest_version}_${latest_revision}"
- set latest_epoch 0
- if {[info exists portinfo(epoch)]} {
- set latest_epoch $portinfo(epoch)
- }
-
- # Compare versions, first checking epoch, then version, then revision
- set comp_result 0
- if {$installed_version != $latest_version} {
- set comp_result [expr {$installed_epoch - $latest_epoch}]
- if { $comp_result == 0 } {
- set comp_result [vercmp $installed_version $latest_version]
- }
- }
- if { $comp_result == 0 } {
- set comp_result [expr {$installed_revision - $latest_revision}]
- }
- if {$comp_result == 0} {
- set regref [registry::open_entry $portname $installed_version $installed_revision $installed_variants $installed_epoch]
- set os_platform_installed [registry::property_retrieve $regref os_platform]
- set os_major_installed [registry::property_retrieve $regref os_major]
- if {$os_platform_installed ne "" && $os_platform_installed != 0
- && $os_major_installed ne "" && $os_major_installed != 0
- && ($os_platform_installed != ${macports::os_platform} || $os_major_installed != ${macports::os_major})} {
- set comp_result -1
- }
- }
-
- # Add outdated ports to our results list
- if { $comp_result < 0 } {
- add_to_portlist results [list name $portname version $installed_compound variants [split_variants $installed_variants]]
- }
- }
- }
-
- return [portlist_sort $results]
-}
-
-
-proc get_obsolete_ports {} {
- set ilist [get_installed_ports]
- set results {}
-
- foreach i $ilist {
- array set port $i
-
- if {[catch {mportlookup $port(name)} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
-
- if {[llength $result] < 2} {
- lappend results $i
- }
- }
-
- # Return the list of ports, already sorted
- return [portlist_sort $results]
-}
-
-# return ports that have registry property $propname set to $propval
-proc get_ports_with_prop {propname propval} {
- set ilist {}
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "port installed failed: $result"
- }
- }
-
- set results {}
- foreach i $ilist {
- set iname [lindex $i 0]
- set iversion [lindex $i 1]
- set irevision [lindex $i 2]
- set ivariants [lindex $i 3]
- set iepoch [lindex $i 5]
- set regref [registry::open_entry $iname $iversion $irevision $ivariants $iepoch]
- if {[registry::property_retrieve $regref $propname] == $propval} {
- add_to_portlist results [list name $iname version "${iversion}_${irevision}" variants [split_variants $ivariants]]
- }
- }
-
- # Return the list of ports, sorted
- return [portlist_sort $results]
-}
-
-proc get_requested_ports {} {
- return [get_ports_with_prop requested 1]
-}
-
-proc get_unrequested_ports {} {
- return [get_ports_with_prop requested 0]
-}
-
-proc get_leaves_ports {} {
- set ilist {}
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "port installed failed: $result"
- }
- }
- registry::open_dep_map
- set results {}
- foreach i $ilist {
- set iname [lindex $i 0]
- if {[registry::list_dependents $iname] eq ""} {
- add_to_portlist results [list name $iname version "[lindex $i 1]_[lindex $i 2]" variants [split_variants [lindex $i 3]]]
- }
- }
- return [portlist_sort [opIntersection $results [get_unrequested_ports]]]
-}
-
-proc get_dependent_ports {portname recursive} {
- registry::open_dep_map
- set deplist [registry::list_dependents $portname]
- # could return specific versions here using registry2.0 features
- set results {}
- foreach dep $deplist {
- add_to_portlist results [list name [lindex $dep 2]]
- }
-
- # actually do this iteratively to avoid hitting Tcl's recursion limit
- if {$recursive} {
- while 1 {
- set rportlist {}
- set newlist {}
- foreach dep $deplist {
- set depname [lindex $dep 2]
- if {![info exists seen($depname)]} {
- set seen($depname) 1
- set rdeplist [registry::list_dependents $depname]
- foreach rdep $rdeplist {
- lappend newlist $rdep
- add_to_portlist rportlist [list name [lindex $rdep 2]]
- }
- }
- }
- if {[llength $rportlist] > 0} {
- set results [opUnion $results $rportlist]
- set deplist $newlist
- } else {
- break
- }
- }
- }
-
- return [portlist_sort $results]
-}
-
-
-proc get_dep_ports {portname recursive} {
- global global_variations
-
- # look up portname
- if {[catch {mportlookup $portname} result]} {
- ui_debug "$::errorInfo"
- return -code error "lookup of portname $portname failed: $result"
- }
- if {[llength $result] < 2} {
- return -code error "Port $portname not found"
- }
- array unset portinfo
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
-
- # open portfile
- if {[catch {set mport [mportopen $porturl [list subport $portinfo(name)] [array get global_variations]]} result]} {
- ui_debug "$::errorInfo"
- return -code error "Unable to open port: $result"
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
-
- # gather its deps
- set results {}
- set deptypes {depends_fetch depends_extract depends_build depends_lib depends_run}
-
- set deplist {}
- foreach type $deptypes {
- if {[info exists portinfo($type)]} {
- foreach dep $portinfo($type) {
- add_to_portlist results [list name [lindex [split $dep :] end]]
- lappend deplist $dep
- }
- }
- }
-
- # actually do this iteratively to avoid hitting Tcl's recursion limit
- if {$recursive} {
- while 1 {
- set rportlist {}
- set newlist {}
- foreach dep $deplist {
- set depname [lindex [split $dep :] end]
- if {![info exists seen($depname)]} {
- set seen($depname) 1
-
- # look up the dep
- if {[catch {mportlookup $depname} result]} {
- ui_debug "$::errorInfo"
- return -code error "lookup of portname $depname failed: $result"
- }
- if {[llength $result] < 2} {
- ui_error "Port $depname not found"
- continue
- }
- array unset portinfo
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
-
- # open its portfile
- if {[catch {set mport [mportopen $porturl [list subport $portinfo(name)] [array get global_variations]]} result]} {
- ui_debug "$::errorInfo"
- ui_error "Unable to open port: $result"
- continue
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
-
- # collect its deps
- set rdeplist {}
- foreach type $deptypes {
- if {[info exists portinfo($type)]} {
- foreach rdep $portinfo($type) {
- add_to_portlist results [list name [lindex [split $rdep :] end]]
- lappend rdeplist $rdep
- }
- }
- }
-
- # add them to the lists
- foreach rdep $rdeplist {
- lappend newlist $rdep
- add_to_portlist rportlist [list name [lindex [split $rdep :] end]]
- }
- }
- }
- if {[llength $rportlist] > 0} {
- set results [opUnion $results $rportlist]
- set deplist $newlist
- } else {
- break
- }
- }
- }
-
- return [portlist_sort $results]
-}
-
-proc get_subports {portname} {
- global global_variations
-
- # look up portname
- if {[catch {mportlookup $portname} result]} {
- ui_debug "$::errorInfo"
- return -code error "lookup of portname $portname failed: $result"
- }
- if {[llength $result] < 2} {
- return -code error "Port $portname not found"
- }
- array unset portinfo
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
-
- # open portfile
- if {[catch {set mport [mportopen $porturl [list subport $portinfo(name)] [array get global_variations]]} result]} {
- ui_debug "$::errorInfo"
- return -code error "Unable to open port: $result"
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
-
- # gather its subports
- set results {}
-
- if {[info exists portinfo(subports)]} {
- foreach subport $portinfo(subports) {
- add_to_portlist results [list name $subport]
- }
- }
-
- return [portlist_sort $results]
-}
-
-
-##########################################
-# Port expressions
-##########################################
-proc portExpr { resname } {
- upvar $resname reslist
- set result [seqExpr reslist]
- return $result
-}
-
-
-proc seqExpr { resname } {
- upvar $resname reslist
-
- # Evaluate a sequence of expressions a b c...
- # These act the same as a or b or c
-
- set result 1
- while {$result} {
- switch -- [lookahead] {
- ; -
- ) -
- _EOF_ { break }
- }
-
- set blist {}
- set result [orExpr blist]
- if {$result} {
- # Calculate the union of result and b
- set reslist [opUnion $reslist $blist]
- }
- }
-
- return $result
-}
-
-
-proc orExpr { resname } {
- upvar $resname reslist
-
- set a [andExpr reslist]
- while ($a) {
- switch -- [lookahead] {
- or {
- advance
- set blist {}
- if {![andExpr blist]} {
- return 0
- }
-
- # Calculate a union b
- set reslist [opUnion $reslist $blist]
- }
- default {
- return $a
- }
- }
- }
-
- return $a
-}
-
-
-proc andExpr { resname } {
- upvar $resname reslist
-
- set a [unaryExpr reslist]
- while {$a} {
- switch -- [lookahead] {
- and {
- advance
-
- set blist {}
- set b [unaryExpr blist]
- if {!$b} {
- return 0
- }
-
- # Calculate a intersect b
- set reslist [opIntersection $reslist $blist]
- }
- default {
- return $a
- }
- }
- }
-
- return $a
-}
-
-
-proc unaryExpr { resname } {
- upvar $resname reslist
- set result 0
-
- switch -- [lookahead] {
- ! -
- not {
- advance
- set blist {}
- set result [unaryExpr blist]
- if {$result} {
- set all [get_all_ports]
- set reslist [opComplement $all $blist]
- }
- }
- default {
- set result [element reslist]
- }
- }
-
- return $result
-}
-
-
-proc element { resname } {
- upvar $resname reslist
- set el 0
-
- set url ""
- set name ""
- set version ""
- array unset requested_variants
- array unset options
-
- set token [lookahead]
- switch -regex -- $token {
- ^\\)$ -
- ^\; -
- ^_EOF_$ { # End of expression/cmd/file
- }
-
- ^\\($ { # Parenthesized Expression
- advance
- set el [portExpr reslist]
- if {!$el || ![match ")"]} {
- set el 0
- }
- }
-
- ^all(@.*)?$ -
- ^installed(@.*)?$ -
- ^uninstalled(@.*)?$ -
- ^active(@.*)?$ -
- ^inactive(@.*)?$ -
- ^actinact(@.*)?$ -
- ^leaves(@.*)?$ -
- ^outdated(@.*)?$ -
- ^obsolete(@.*)?$ -
- ^requested(@.*)?$ -
- ^unrequested(@.*)?$ -
- ^current(@.*)?$ {
- # A simple pseudo-port name
- advance
-
- # Break off the version component, if there is one
- regexp {^(\w+)(@.*)?} $token matchvar name remainder
-
- add_multiple_ports reslist [get_${name}_ports] $remainder
-
- set el 1
- }
-
- ^variants: -
- ^variant: -
- ^description: -
- ^portdir: -
- ^homepage: -
- ^epoch: -
- ^platforms: -
- ^platform: -
- ^name: -
- ^long_description: -
- ^maintainers: -
- ^maintainer: -
- ^categories: -
- ^category: -
- ^version: -
- ^depends_lib: -
- ^depends_build: -
- ^depends_run: -
- ^depends_extract: -
- ^depends_fetch: -
- ^replaced_by: -
- ^revision: -
- ^subport: -
- ^subports: -
- ^license: { # Handle special port selectors
- advance
-
- # Break up the token, because older Tcl switch doesn't support -matchvar
- regexp {^(\w+):(.*)} $token matchvar field pat
-
- # Remap friendly names to actual names
- set field [map_friendly_field_names $field]
-
- add_multiple_ports reslist [get_matching_ports $pat no regexp $field]
- set el 1
- }
-
- ^depends: { # A port selector shorthand for depends_{lib,build,run,fetch,extract}
- advance
-
- # Break up the token, because older Tcl switch doesn't support -matchvar
- regexp {^(\w+):(.*)} $token matchvar field pat
-
- add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_lib"]
- add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_build"]
- add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_run"]
- add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_extract"]
- add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_fetch"]
-
- set el 1
- }
-
- ^dependentof: -
- ^rdependentof: {
- advance
-
- # Break up the token, because older Tcl switch doesn't support -matchvar
- regexp {^(\w+):(.*)} $token matchvar selector portname
-
- set recursive [string equal $selector "rdependentof"]
- add_multiple_ports reslist [get_dependent_ports $portname $recursive]
-
- set el 1
- }
-
- ^depof: -
- ^rdepof: {
- advance
-
- # Break up the token, because older Tcl switch doesn't support -matchvar
- regexp {^(\w+):(.*)} $token matchvar selector portname
-
- set recursive [string equal $selector "rdepof"]
- add_multiple_ports reslist [get_dep_ports $portname $recursive]
-
- set el 1
- }
-
- ^subportof: {
- advance
-
- # Break up the token, because older Tcl switch doesn't support -matchvar
- regexp {^(\w+):(.*)} $token matchvar selector portname
-
- add_multiple_ports reslist [get_subports $portname]
-
- set el 1
- }
-
- [][?*] { # Handle portname glob patterns
- advance; add_multiple_ports reslist [get_matching_ports $token no glob]
- set el 1
- }
-
- ^\\w+:.+ { # Handle a url by trying to open it as a port and mapping the name
- advance
- set name [url_to_portname $token]
- if {$name ne ""} {
- parsePortSpec version requested_variants options
- add_to_portlist reslist [list url $token \
- name $name \
- version $version \
- requested_variants [array get requested_variants] \
- variants [array get requested_variants] \
- options [array get options]]
- set el 1
- } else {
- ui_error "Can't open URL '$token' as a port"
- set el 0
- }
- }
-
- default { # Treat anything else as a portspec (portname, version, variants, options
- # or some combination thereof).
- parseFullPortSpec url name version requested_variants options
- add_to_portlist reslist [list url $url \
- name $name \
- version $version \
- requested_variants [array get requested_variants] \
- variants [array get requested_variants] \
- options [array get options]]
- set el 1
- }
- }
-
- return $el
-}
-
-
-proc add_multiple_ports { resname ports {remainder ""} } {
- upvar $resname reslist
-
- set version ""
- array unset variants
- array unset options
- parsePortSpec version variants options $remainder
-
- array unset overrides
- if {$version ne ""} { set overrides(version) $version }
- if {[array size variants]} {
- # we always record the requested variants separately,
- # but requested ones always override existing ones
- set overrides(requested_variants) [array get variants]
- set overrides(variants) [array get variants]
- }
- if {[array size options]} { set overrides(options) [array get options] }
-
- add_ports_to_portlist reslist $ports [array get overrides]
-}
-
-
-proc unique_entries { entries } {
- # Form the list of all the unique elements in the list a,
- # considering only the port fullname, and taking the first
- # found element first
- set result {}
- array unset unique
- foreach item $entries {
- array set port $item
- if {[info exists unique($port(fullname))]} continue
- set unique($port(fullname)) 1
- lappend result $item
- }
- return $result
-}
-
-
-proc opUnion { a b } {
- # Return the unique elements in the combined two lists
- return [unique_entries [concat $a $b]]
-}
-
-
-proc opIntersection { a b } {
- set result {}
-
- # Rules we follow in performing the intersection of two port lists:
- #
- # a/, a/ ==> a/
- # a/, b/ ==>
- # a/, a/1.0 ==> a/1.0
- # a/1.0, a/ ==> a/1.0
- # a/1.0, a/2.0 ==>
- #
- # If there's an exact match, we take it.
- # If there's a match between simple and discriminated, we take the later.
-
- # First create a list of the fully discriminated names in b
- array unset bfull
- set i 0
- foreach bitem [unique_entries $b] {
- array set port $bitem
- set bfull($port(fullname)) $i
- incr i
- }
-
- # Walk through each item in a, matching against b
- foreach aitem [unique_entries $a] {
- array set port $aitem
-
- # Quote the fullname and portname to avoid special characters messing up the regexp
- set safefullname [regex_pat_sanitize $port(fullname)]
-
- set simpleform [expr { "$port(name)/" == $port(fullname) }]
- if {$simpleform} {
- set pat "^${safefullname}"
- } else {
- set safename [regex_pat_sanitize $port(name)]
- set pat "^${safefullname}$|^${safename}/$"
- }
-
- set matches [array names bfull -regexp $pat]
- foreach match $matches {
- if {$simpleform} {
- set i $bfull($match)
- lappend result [lindex $b $i]
- } else {
- lappend result $aitem
- }
- }
- }
-
- return $result
-}
-
-
-proc opComplement { a b } {
- set result {}
-
- # Return all elements of a not matching elements in b
-
- # First create a list of the fully discriminated names in b
- array unset bfull
- set i 0
- foreach bitem $b {
- array set port $bitem
- set bfull($port(fullname)) $i
- incr i
- }
-
- # Walk through each item in a, taking all those items that don't match b
- foreach aitem $a {
- array set port $aitem
-
- # Quote the fullname and portname to avoid special characters messing up the regexp
- set safefullname [regex_pat_sanitize $port(fullname)]
-
- set simpleform [expr { "$port(name)/" == $port(fullname) }]
- if {$simpleform} {
- set pat "^${safefullname}"
- } else {
- set safename [regex_pat_sanitize $port(name)]
- set pat "^${safefullname}$|^${safename}/$"
- }
-
- set matches [array names bfull -regexp $pat]
-
- # We copy this element to result only if it didn't match against b
- if {![llength $matches]} {
- lappend result $aitem
- }
- }
-
- return $result
-}
-
-
-proc parseFullPortSpec { urlname namename vername varname optname } {
- upvar $urlname porturl
- upvar $namename portname
- upvar $vername portversion
- upvar $varname portvariants
- upvar $optname portoptions
-
- set portname ""
- set portversion ""
- array unset portvariants
- array unset portoptions
-
- if { [moreargs] } {
- # Look first for a potential portname
- #
- # We need to allow a wide variety of tokens here, because of actions like "provides"
- # so we take a rather lenient view of what a "portname" is. We allow
- # anything that doesn't look like either a version, a variant, or an option
- set token [lookahead]
-
- set remainder ""
- if {|[[:alpha:]_]+[\w\.]*=)} $token match]} {
- advance
- regexp {^([^@]+)(@.*)?} $token match portname remainder
-
- # If the portname contains a /, then try to use it as a URL
- if {[string match "*/*" $portname]} {
- set url "file://$portname"
- set name [url_to_portname $url 1]
- if { $name ne "" } {
- # We mapped the url to valid port
- set porturl $url
- set portname $name
- # Continue to parse rest of portspec....
- } else {
- # We didn't map the url to a port; treat it
- # as a raw string for something like port contents
- # or cd
- set porturl ""
- # Since this isn't a port, we don't try to parse
- # any remaining portspec....
- return
- }
- }
- }
-
- # Now parse the rest of the spec
- parsePortSpec portversion portvariants portoptions $remainder
- }
-}
-
-# check if the install prefix is writable
-# should be called by actions that will modify it
-proc prefix_unwritable {} {
- global macports::portdbpath
- if {[file writable $portdbpath]} {
- return 0
- } else {
- ui_error "Insufficient privileges to write to MacPorts install prefix."
- return 1
- }
-}
-
-
-proc parsePortSpec { vername varname optname {remainder ""} } {
- upvar $vername portversion
- upvar $varname portvariants
- upvar $optname portoptions
-
- global global_options
-
- set portversion ""
- array unset portoptions
- array set portoptions [array get global_options]
- array unset portvariants
-
- # Parse port version/variants/options
- set opt $remainder
- set adv 0
- set consumed 0
- for {set firstTime 1} {$opt ne "" || [moreargs]} {set firstTime 0} {
-
- # Refresh opt as needed
- if {$opt eq ""} {
- if {$adv} advance
- set opt [lookahead]
- set adv 1
- set consumed 0
- }
-
- # Version must be first, if it's there at all
- if {$firstTime && [string match {@*} $opt]} {
- # Parse the version
-
- # Strip the @
- set opt [string range $opt 1 end]
-
- # Handle the version
- set sepPos [string first "/" $opt]
- if {$sepPos >= 0} {
- # Version terminated by "/" to disambiguate -variant from part of version
- set portversion [string range $opt 0 [expr {$sepPos - 1}]]
- set opt [string range $opt [expr {$sepPos + 1}] end]
- } else {
- # Version terminated by "+", or else is complete
- set sepPos [string first "+" $opt]
- if {$sepPos >= 0} {
- # Version terminated by "+"
- set portversion [string range $opt 0 [expr {$sepPos - 1}]]
- set opt [string range $opt $sepPos end]
- } else {
- # Unterminated version
- set portversion $opt
- set opt ""
- }
- }
- set consumed 1
- } else {
- # Parse all other options
-
- # Look first for a variable setting: VARNAME=VALUE
- if {[regexp {^([[:alpha:]_]+[\w\.]*)=(.*)} $opt match key val] == 1} {
- # It's a variable setting
- set portoptions($key) "\"$val\""
- set opt ""
- set consumed 1
- } elseif {[regexp {^([-+])([[:alpha:]_]+[\w\.]*)} $opt match sign variant] == 1} {
- # It's a variant
- set portvariants($variant) $sign
- set opt [string range $opt [expr {[string length $variant] + 1}] end]
- set consumed 1
- } else {
- # Not an option we recognize, so break from port option processing
- if { $consumed && $adv } advance
- break
- }
- }
- }
-}
-
-
-##########################################
-# Action Handlers
-##########################################
-
-proc action_get_usage { action } {
- global action_array cmd_opts_array
-
- if {[info exists action_array($action)]} {
- set cmds ""
- if {[info exists cmd_opts_array($action)]} {
- foreach opt $cmd_opts_array($action) {
- if {[llength $opt] == 1} {
- set name $opt
- set optc 0
- } else {
- set name [lindex $opt 0]
- set optc [lindex $opt 1]
- }
-
- append cmds " --$name"
-
- for {set i 1} {$i <= $optc} {incr i} {
- append cmds " <arg$i>"
- }
- }
- }
- set args ""
- set needed [action_needs_portlist $action]
- if {[ACTION_ARGS_STRINGS] == $needed} {
- set args " <arguments>"
- } elseif {[ACTION_ARGS_STRINGS] == $needed} {
- set args " <portlist>"
- }
-
- set ret "Usage: "
- set len [string length $action]
- append ret [wrap "$action$cmds$args" 0 [string repeat " " [expr {8 + $len}]] 0]
- append ret "\n"
-
- return $ret
- }
-
- return -1
-}
-
-proc action_usage { action portlist opts } {
- if {[llength $portlist] == 0} {
- print_usage
- return 0
- }
-
- foreach topic $portlist {
- set usage [action_get_usage $topic]
- if {$usage != -1} {
- puts -nonewline stderr $usage
- } else {
- ui_error "No usage for topic $topic"
- return 1
- }
- }
- return 0
-}
-
-
-proc action_help { action portlist opts } {
- set helpfile "$macports::prefix/var/macports/port-help.tcl"
-
- if {[llength $portlist] == 0} {
- print_help
- return 0
- }
-
- if {[file exists $helpfile]} {
- if {[catch {source $helpfile} err]} {
- puts stderr "Error reading helpfile $helpfile: $err"
- return 1
- }
- } else {
- puts stderr "Unable to open help file $helpfile"
- return 1
- }
-
- foreach topic $portlist {
- if {![info exists porthelp($topic)]} {
- puts stderr "No help for topic $topic"
- return 1
- }
-
- set usage [action_get_usage $topic]
- if {$usage != -1} {
- puts -nonewline stderr $usage
- } else {
- ui_error "No usage for topic $topic"
- return 1
- }
-
- puts stderr $porthelp($topic)
- }
-
- return 0
-}
-
-
-proc action_log { action portlist opts } {
- global global_options
- if {[require_portlist portlist]} {
- return 1
- }
- foreachport $portlist {
- # If we have a url, use that, since it's most specific
- # otherwise try to map the portname to a url
- if {$porturl eq ""} {
- # Verify the portname, getting portinfo to map to a porturl
- if {[catch {mportlookup $portname} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Port $portname not found" 1 status
- }
- array unset portinfo
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
- set portdir $portinfo(portdir)
- set portname $portinfo(name)
- } elseif {$porturl ne "file://."} {
- # Extract the portdir from porturl and use it to search PortIndex.
- # Only the last two elements of the path (porturl) make up the
- # portdir.
- set portdir [file split [macports::getportdir $porturl]]
- set lsize [llength $portdir]
- set portdir \
- [file join [lindex $portdir [expr {$lsize - 2}]] \
- [lindex $portdir [expr {$lsize - 1}]]]
- if {[catch {mportsearch $portdir no exact portdir} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Portdir $portdir not found" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Portdir $portdir not found" 1 status
- }
- array unset portinfo
- set matchindex [lsearch -exact -nocase $result $portname]
- if {$matchindex != -1} {
- array set portinfo [lindex $result [incr matchindex]]
- } else {
- ui_warn "Portdir $portdir doesn't seem to belong to portname $portname"
- array set portinfo [lindex $result 1]
- }
- set portname $portinfo(name)
- }
- set portpath [macports::getportdir $porturl]
- set logfile [file join [macports::getportlogpath $portpath $portname] "main.log"]
- if {[file exists $logfile]} {
- if {[catch {set fp [open $logfile r]} result]} {
- break_softcontinue "Could not open file $logfile: $result" 1 status
- }
- set data [read $fp]
- set data [split $data "\n"]
-
- if {[info exists global_options(ports_log_phase)]} {
- set phase $global_options(ports_log_phase);
- } else {
- set phase "\[a-z\]*"
- }
-
- if {[info exists global_options(ports_log_level)]} {
- set index [lsearch -exact ${macports::ui_priorities} $global_options(ports_log_level)]
- if {$index == -1} {
- set prefix ""
- } else {
- set prefix [join [lrange ${macports::ui_priorities} 0 $index] "|"]
- }
- } else {
- set prefix "\[a-z\]*"
- }
- foreach line $data {
- set exp "^:($prefix|any):($phase|any) (.*)$"
- if {[regexp $exp $line -> lpriority lphase lmsg] == 1} {
- puts "[macports::ui_prefix_default $lpriority]$lmsg"
- }
- }
-
- close $fp
- } else {
- break_softcontinue "Log file for port $portname not found" 1 status
- }
- }
- return 0
-}
-
-
-proc action_info { action portlist opts } {
- global global_variations
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
-
- set separator ""
- foreachport $portlist {
- set index_only 0
- if {[info exists options(ports_info_index)] && $options(ports_info_index)} {
- set index_only 1
- }
- puts -nonewline $separator
- array unset portinfo
- # If we have a url, use that, since it's most specific
- # otherwise try to map the portname to a url
- if {$porturl eq "" || $index_only} {
- # Verify the portname, getting portinfo to map to a porturl
- if {[catch {mportlookup $portname} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Port $portname not found" 1 status
- }
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
- set portdir $portinfo(portdir)
- }
-
- if {!$index_only} {
- # Add any global_variations to the variations
- # specified for the port (so we get e.g. dependencies right)
- array unset merged_variations
- array set merged_variations [array get variations]
- foreach { variation value } [array get global_variations] {
- if { ![info exists merged_variations($variation)] } {
- set merged_variations($variation) $value
- }
- }
- if {![info exists options(subport)]} {
- if {[info exists portinfo(name)]} {
- set options(subport) $portinfo(name)
- } else {
- set options(subport) $portname
- }
- }
-
- if {[catch {set mport [mportopen $porturl [array get options] [array get merged_variations]]} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Unable to open port: $result" 1 status
- }
- unset options(subport)
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
- if {[info exists portdir]} {
- set portinfo(portdir) $portdir
- }
- } elseif {![info exists portinfo]} {
- ui_warn "no PortIndex entry found for $portname"
- continue
- }
- array unset options ports_info_index
-
- # Understand which info items are actually lists
- # (this could be overloaded to provide a generic formatting code to
- # allow us to, say, split off the prefix on libs)
- array set list_map "
- categories 1
- depends_fetch 1
- depends_extract 1
- depends_build 1
- depends_lib 1
- depends_run 1
- maintainers 1
- platforms 1
- variants 1
- conflicts 1
- subports 1
- "
-
- # Label map for pretty printing
- array set pretty_label {
- heading ""
- variants Variants
- depends_fetch "Fetch Dependencies"
- depends_extract "Extract Dependencies"
- depends_build "Build Dependencies"
- depends_run "Runtime Dependencies"
- depends_lib "Library Dependencies"
- description "Brief Description"
- long_description "Description"
- fullname "Full Name: "
- homepage Homepage
- platforms Platforms
- maintainers Maintainers
- license License
- conflicts "Conflicts with"
- replaced_by "Replaced by"
- subports "Sub-ports"
- }
-
- # Wrap-length map for pretty printing
- array set pretty_wrap {
- heading 0
- replaced_by 22
- variants 22
- depends_fetch 22
- depends_extract 22
- depends_build 22
- depends_run 22
- depends_lib 22
- description 22
- long_description 22
- homepage 22
- platforms 22
- license 22
- conflicts 22
- maintainers 22
- subports 22
- }
-
- # Interpret a convenient field abbreviation
- if {[info exists options(ports_info_depends)] && $options(ports_info_depends) eq "yes"} {
- array unset options ports_info_depends
- set options(ports_info_depends_fetch) yes
- set options(ports_info_depends_extract) yes
- set options(ports_info_depends_build) yes
- set options(ports_info_depends_lib) yes
- set options(ports_info_depends_run) yes
- }
-
- # Set up our field separators
- set show_label 1
- set field_sep "\n"
- set subfield_sep ", "
- set pretty_print 0
-
- # For human-readable summary, which is the default with no options
- if {[llength [array get options ports_info_*]] == 0} {
- set pretty_print 1
- } elseif {[info exists options(ports_info_pretty)]} {
- set pretty_print 1
- array unset options ports_info_pretty
- }
-
- # Tune for sort(1)
- if {[info exists options(ports_info_line)]} {
- array unset options ports_info_line
- set noseparator 1
- set show_label 0
- set field_sep "\t"
- set subfield_sep ","
- }
-
- # Figure out whether to show field name
- set quiet [macports::ui_isset ports_quiet]
- if {$quiet} {
- set show_label 0
- }
- # In pretty-print mode we also suppress messages, even though we show
- # most of the labels:
- if {$pretty_print} {
- set quiet 1
- }
-
- # Spin through action options, emitting information for any found
- set fields {}
- set opts_todo [array names options ports_info_*]
- set fields_tried {}
- if {![llength $opts_todo]} {
- set opts_todo {ports_info_heading
- ports_info_replaced_by
- ports_info_subports
- ports_info_variants
- ports_info_skip_line
- ports_info_long_description ports_info_homepage
- ports_info_skip_line ports_info_depends_fetch
- ports_info_depends_extract ports_info_depends_build
- ports_info_depends_lib ports_info_depends_run
- ports_info_conflicts
- ports_info_platforms ports_info_license
- ports_info_maintainers
- }
- }
- foreach { option } $opts_todo {
- set opt [string range $option 11 end]
- # Artificial field name for formatting
- if {$pretty_print && $opt eq "skip_line"} {
- lappend fields ""
- continue
- }
- # Artificial field names to reproduce prettyprinted summary
- if {$opt eq "heading"} {
- set inf "$portinfo(name) @$portinfo(version)"
- set ropt "heading"
- if {[info exists portinfo(revision)] && $portinfo(revision) > 0} {
- append inf "_$portinfo(revision)"
- }
- if {[info exists portinfo(categories)]} {
- append inf " ([join $portinfo(categories) ", "])"
- }
- } elseif {$opt eq "fullname"} {
- set inf "$portinfo(name) @"
- append inf [composite_version $portinfo(version) $portinfo(active_variants)]
- set ropt "fullname"
- } else {
- # Map from friendly name
- set ropt [map_friendly_field_names $opt]
-
- # If there's no such info, move on
- if {![info exists portinfo($ropt)]} {
- set inf ""
- } else {
- set inf [join $portinfo($ropt)]
- }
- }
-
- # Calculate field label
- set label ""
- if {$pretty_print} {
- if {[info exists pretty_label($ropt)]} {
- set label $pretty_label($ropt)
- } else {
- set label $opt
- }
- } elseif {$show_label} {
- set label "$opt: "
- }
-
- # Format the data
- if { $ropt eq "maintainers" } {
- set inf [unobscure_maintainers $inf]
- }
- # ... special formatting for certain fields when prettyprinting
- if {$pretty_print} {
- if {$ropt eq "variants"} {
- # Use the new format for variants iff it exists in
- # PortInfo. This key currently does not exist outside of
- # trunk (1.8.0).
- array unset vinfo
- if {[info exists portinfo(vinfo)]} {
- array set vinfo $portinfo(vinfo)
- }
-
- set pi_vars $inf
- set inf {}
- foreach v [lsort $pi_vars] {
- set varmodifier ""
- if {[info exists variations($v)]} {
- # selected by command line, prefixed with +/-
- set varmodifier $variations($v)
- } elseif {[info exists global_variations($v)]} {
- # selected by variants.conf, prefixed with (+)/(-)
- set varmodifier "($global_variations($v))"
- # Retrieve additional information from the new key.
- } elseif {[info exists vinfo]} {
- array unset variant
- array set variant $vinfo($v)
- if {[info exists variant(is_default)]} {
- set varmodifier "\[$variant(is_default)]"
- }
- }
- lappend inf "$varmodifier$v"
- }
- } elseif {[string match "depend*" $ropt]
- && ![macports::ui_isset ports_verbose]} {
- set pi_deps $inf
- set inf {}
- foreach d $pi_deps {
- lappend inf [lindex [split $d :] end]
- }
- }
- }
- #End of special pretty-print formatting for certain fields
- if {[info exists list_map($ropt)]} {
- set field [join $inf $subfield_sep]
- } else {
- set field $inf
- }
-
- # Assemble the entry
- if {$pretty_print} {
- # The two special fields are considered headings and are
- # emitted immediately, rather than waiting. Also they are not
- # recorded on the list of fields tried
- if {$ropt eq "heading" || $ropt eq "fullname"} {
- puts "$label$field"
- continue
- }
- }
- lappend fields_tried $label
- if {$pretty_print} {
- if {$field eq ""} {
- continue
- }
- if {$label eq ""} {
- set wrap_len 0
- if {[info exists pretty_wrap($ropt)]} {
- set wrap_len $pretty_wrap($ropt)
- }
- lappend fields [wrap $field 0 [string repeat " " $wrap_len]]
- } else {
- set wrap_len [string length $label]
- if {[info exists pretty_wrap($ropt)]} {
- set wrap_len $pretty_wrap($ropt)
- }
- lappend fields [wraplabel $label $field 0 [string repeat " " $wrap_len]]
- }
-
- } else { # Not pretty print
- lappend fields "$label$field"
- }
- }
-
- # Now output all that information:
- if {[llength $fields]} {
- puts [join $fields $field_sep]
- } else {
- if {$pretty_print && [llength $fields_tried]} {
- puts -nonewline "$portinfo(name) has no "
- puts [join $fields_tried ", "]
- }
- }
- if {![info exists noseparator]} {
- set separator "--\n"
- }
- }
-
- return $status
-}
-
-
-proc action_location { action portlist opts } {
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
- foreachport $portlist {
- if { [catch {set ilist [registry_installed $portname [composite_version $portversion [array get variations]]]} result] } {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port location failed: $result" 1 status
- } else {
- # set portname again since the one we were passed may not have had the correct case
- set portname [lindex $ilist 0]
- set version [lindex $ilist 1]
- set revision [lindex $ilist 2]
- set variants [lindex $ilist 3]
- set epoch [lindex $ilist 5]
- }
-
- set ref [registry::open_entry $portname $version $revision $variants $epoch]
- set imagedir [registry::property_retrieve $ref location]
- ui_notice "Port $portname ${version}_${revision}${variants} is installed as an image in:"
- puts $imagedir
- }
-
- return $status
-}
-
-
-proc action_notes { action portlist opts } {
- if {[require_portlist portlist]} {
- return 1
- }
-
- set status 0
- foreachport $portlist {
- array unset portinfo
- if {$porturl eq ""} {
- # Look up the port.
- if {[catch {mportlookup $portname} result]} {
- ui_debug $::errorInfo
- break_softcontinue "The lookup of '$portname' failed: $result" \
- 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "The port '$portname' was not found" 1 status
- }
-
- # Retrieve the port's URL.
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
- }
-
- # Add any global_variations to the variations
- # specified for the port
- array unset merged_variations
- array set merged_variations [array get variations]
- foreach { variation value } [array get global_variations] {
- if { ![info exists merged_variations($variation)] } {
- set merged_variations($variation) $value
- }
- }
- if {![info exists options(subport)]} {
- if {[info exists portinfo(name)]} {
- set options(subport) $portinfo(name)
- } else {
- set options(subport) $portname
- }
- }
-
- # Open the Portfile associated with this port.
- if {[catch {set mport [mportopen $porturl [array get options] \
- [array get merged_variations]]} \
- result]} {
- ui_debug $::errorInfo
- break_softcontinue [concat "The URL '$porturl' could not be" \
- "opened: $result"] 1 status
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
-
- # Return the notes associated with this Portfile.
- if {[info exists portinfo(notes)]} {
- set portnotes $portinfo(notes)
- } else {
- set portnotes {}
- }
-
- # Retrieve the port's name once more to ensure it has the proper case.
- set portname $portinfo(name)
-
- # Display the notes.
- if {$portnotes ne {}} {
- ui_notice "$portname has the following notes:"
- foreach note $portnotes {
- puts [wrap $note 0 " " 1]
- }
- } else {
- puts "$portname has no notes."
- }
- }
- return $status
-}
-
-
-proc action_provides { action portlist opts } {
- # In this case, portname is going to be used for the filename... since
- # that is the first argument we expect... perhaps there is a better way
- # to do this?
- if { ![llength $portlist] } {
- ui_error "Please specify a filename to check which port provides that file."
- return 1
- }
- foreach filename $portlist {
- set file [file normalize $filename]
- if {[file exists $file] || ![catch {file type $file}]} {
- if {![file isdirectory $file] || [file type $file] eq "link"} {
- set port [registry::file_registered $file]
- if { $port != 0 } {
- puts "$file is provided by: $port"
- } else {
- puts "$file is not provided by a MacPorts port."
- }
- } else {
- puts "$file is a directory."
- }
- } else {
- puts "$file does not exist."
- }
- }
- registry::close_file_map
-
- return 0
-}
-
-
-proc action_activate { action portlist opts } {
- set status 0
- if {[require_portlist portlist] || [prefix_unwritable]} {
- return 1
- }
- foreachport $portlist {
- set composite_version [composite_version $portversion [array get variations]]
- if {![info exists options(ports_activate_no-exec)]
- && ![catch {set ilist [registry::installed $portname $composite_version]}]
- && [llength $ilist] == 1} {
-
- set i [lindex $ilist 0]
- set regref [registry::entry open $portname [lindex $i 1] [lindex $i 2] [lindex $i 3] [lindex $i 5]]
- if {[$regref installtype] eq "image" && [registry::run_target $regref activate [array get options]]} {
- continue
- }
- }
- if {![macports::global_option_isset ports_dryrun]} {
- if { [catch {portimage::activate_composite $portname $composite_version [array get options]} result] } {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port activate failed: $result" 1 status
- }
- } else {
- ui_msg "Skipping activate $portname (dry run)"
- }
- }
-
- return $status
-}
-
-
-proc action_deactivate { action portlist opts } {
- set status 0
- if {[require_portlist portlist] || [prefix_unwritable]} {
- return 1
- }
- set portlist [portlist_sortdependents $portlist]
- foreachport $portlist {
- set composite_version [composite_version $portversion [array get variations]]
- if {![info exists options(ports_deactivate_no-exec)]
- && ![catch {set ilist [registry::active $portname]}]} {
-
- set i [lindex $ilist 0]
- set iversion [lindex $i 1]
- set irevision [lindex $i 2]
- set ivariants [lindex $i 3]
- if {$composite_version eq "" || $composite_version == "${iversion}_${irevision}${ivariants}"} {
- set regref [registry::entry open $portname $iversion $irevision $ivariants [lindex $i 5]]
- if {[$regref installtype] eq "image" && [registry::run_target $regref deactivate [array get options]]} {
- continue
- }
- }
- }
- if {![macports::global_option_isset ports_dryrun]} {
- if { [catch {portimage::deactivate_composite $portname $composite_version [array get options]} result] } {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port deactivate failed: $result" 1 status
- }
- } else {
- ui_msg "Skipping deactivate $portname (dry run)"
- }
- }
-
- return $status
-}
-
-
-proc action_select { action portlist opts } {
- ui_debug "action_select \[$portlist] \[$opts]..."
-
- array set opts_array $opts
- set commands [array names opts_array ports_select_*]
- array unset opts_array
-
- # Error out if no group is specified or command is not --summary.
- if {[llength $portlist] < 1 && [string map {ports_select_ ""} [lindex $commands 0]] != "summary"} {
- ui_error "port select \[--list|--set|--show|--summary] \<group> \[<version>]"
- return 1
- }
-
- set group [lindex $portlist 0]
-
- # If no command (--set, --show, --list, --summary) is specified *but*
- # more than one argument is specified, default to the set command.
- if {[llength $commands] < 1 && [llength $portlist] > 1} {
- set command set
- ui_debug [concat "Although no command was specified, more than " \
- "one argument was specified. Defaulting to the " \
- "'set' command..."]
- # If no command (--set, --show, --list) is specified *and* less than two
- # argument are specified, default to the list command.
- } elseif {[llength $commands] < 1} {
- set command list
- ui_debug [concat "No command was specified. Defaulting to the " \
- "'list' command..."]
- # Only allow one command to be specified at a time.
- } elseif {[llength $commands] > 1} {
- ui_error [concat "Multiple commands were specified. Only one " \
- "command may be specified at a time."]
- return 1
- } else {
- set command [string map {ports_select_ ""} [lindex $commands 0]]
- ui_debug "The '$command' command was specified."
- }
-
- switch -- $command {
- list {
- if {[llength $portlist] > 1} {
- ui_warn [concat "The 'list' command does not expect any " \
- "arguments. Extra arguments will be ignored."]
- }
-
- if {[catch {mportselect show $group} selected_version]} {
- global errorInfo
- ui_debug $errorInfo
- ui_warn "Unable to get active selected version: $selected_version"
- }
-
- # On error mportselect returns with the code 'error'.
- if {[catch {mportselect $command $group} versions]} {
- ui_error "The 'list' command failed: $versions"
- return 1
- }
-
- ui_notice "Available versions for $group:"
- foreach v $versions {
- ui_notice -nonewline "\t"
- if {$selected_version == $v} {
- ui_msg "$v (active)"
- } else {
- ui_msg "$v"
- }
- }
- return 0
- }
- set {
- if {[llength $portlist] < 2} {
- ui_error [concat "The 'set' command expects two " \
- "arguments: <group>, <version>"]
- return 1
- } elseif {[llength $portlist] > 2} {
- ui_warn [concat "The 'set' command only expects two " \
- "arguments. Extra arguments will be " \
- "ignored."]
- }
- set version [lindex $portlist 1]
-
- ui_msg -nonewline "Selecting '$version' for '$group' "
- if {[catch {mportselect $command $group $version} result]} {
- ui_msg "failed: $result"
- return 1
- }
- ui_msg "succeeded. '$version' is now active."
- return 0
- }
- show {
- if {[llength $portlist] > 1} {
- ui_warn [concat "The 'show' command does not expect any " \
- "arguments. Extra arguments will be ignored."]
- }
-
- if {[catch {mportselect $command $group} selected_version]} {
- ui_error "The 'show' command failed: $selected_version"
- return 1
- }
- puts [concat "The currently selected version for '$group' is " \
- "'$selected_version'."]
- return 0
- }
- summary {
- if {[llength $portlist] > 0} {
- ui_warn [concat "The 'summary' command does not expect any " \
- "arguments. Extra arguments will be ignored."]
- }
-
- if {[catch {mportselect $command} portgroups]} {
- ui_error "The 'summary' command failed: $portgroups"
- return 1
- }
-
- set w1 4
- set w2 8
- set formatStr "%-*s %-*s %s"
-
- set groups [list]
- foreach pg $portgroups {
- array set groupdesc {}
- set groupdesc(name) [string trim $pg]
-
- if {[catch {mportselect list $pg} versions]} {
- ui_warn "The list of options for the select group $pg could not be obtained: $versions"
- continue
- }
- # remove "none", sort the list, append none at the end
- set noneidx [lsearch -exact $versions "none"]
- set versions [lsort [lreplace $versions $noneidx $noneidx]]
- lappend versions "none"
- set groupdesc(versions) $versions
-
- if {[catch {mportselect show $pg} selected_version]} {
- ui_warn "The currently selected option for the select group $pg could not be obtained: $selected_version"
- continue
- }
- set groupdesc(selected) $selected_version
-
- set w1 [expr {max($w1, [string length $pg])}]
- set w2 [expr {max($w2, [string length $selected_version])}]
-
- lappend groups [array get groupdesc]
- array unset groupdesc
- }
- puts [format $formatStr $w1 "Name" $w2 "Selected" "Options"]
- puts [format $formatStr $w1 "====" $w2 "========" "======="]
- foreach groupdesc $groups {
- array set groupd $groupdesc
- puts [format $formatStr $w1 $groupd(name) $w2 $groupd(selected) [join $groupd(versions) " "]]
- array unset groupd
- }
- return 0
- }
- default {
- ui_error "An unknown command '$command' was specified."
- return 1
- }
- }
-}
-
-
-proc action_selfupdate { action portlist opts } {
- global global_options
- if { [catch {macports::selfupdate [array get global_options] base_updated} result ] } {
- global errorInfo
- ui_debug "$errorInfo"
- ui_error "$result"
- if {![macports::ui_isset ports_verbose]} {
- ui_msg "Please run `port -v selfupdate' for details."
- } else {
- # Let's only print the ticket URL if the user has followed the
- # advice we printed earlier.
- print_tickets_url
- }
- fatal "port selfupdate failed: $result"
- }
-
- if {$base_updated} {
- # exit immediately if in batch/interactive mode
- return -999
- } else {
- return 0
- }
-}
-
-
-proc action_setrequested { action portlist opts } {
- set status 0
- if {[require_portlist portlist] || [prefix_unwritable]} {
- return 1
- }
- # set or unset?
- set val [string equal $action "setrequested"]
- foreachport $portlist {
- set composite_version [composite_version $portversion [array get variations]]
- if {![catch {set ilist [registry::installed $portname $composite_version]} result]} {
- ui_info "Setting requested flag for $portname to $val"
- foreach i $ilist {
- set regref [registry::open_entry $portname [lindex $i 1] [lindex $i 2] [lindex $i 3] [lindex $i 5]]
- registry::property_store $regref requested $val
- }
- } else {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "$result" 1 status
- }
- }
-
- return $status
-}
-
-
-proc action_upgrade { action portlist opts } {
- if {[require_portlist portlist "yes"] || ([prefix_unwritable] && ![macports::global_option_isset ports_dryrun])} {
- return 1
- }
-
- # shared depscache for all ports in the list
- array set depscache {}
- set status 0
- foreachport $portlist {
- if {![info exists depscache(port:$portname)]} {
- set status [macports::upgrade $portname "port:$portname" [array get requested_variations] [array get options] depscache]
- # status 2 means the port was not found in the index,
- # status 3 means the port is not installed
- if {$status != 0 && $status != 2 && $status != 3 && ![macports::ui_isset ports_processall]} {
- break
- }
- }
- }
-
- if {$status != 0 && $status != 2 && $status != 3} {
- print_tickets_url
- } elseif {$status == 0} {
- array set options $opts
- if {![info exists options(ports_upgrade_no-rev-upgrade)] && ${macports::revupgrade_autorun} && ![macports::global_option_isset ports_dryrun]} {
- set status [action_revupgrade $action $portlist $opts]
- }
- }
-
- return $status
-}
-
-proc action_doctor { action portlist opts } {
-<<<<<<< HEAD
- macports::doctor_main
-=======
- if {[prefix_unwritable]} {
- return 1
- }
- macports::doctor_main $opts
->>>>>>> svn
- return 0
-}
-
-proc action_reclaim { action portlist opts } {
-<<<<<<< HEAD
-=======
- if {[prefix_unwritable]} {
- return 1
- }
->>>>>>> svn
- macports::reclaim_main
- return 0
-}
-
-proc action_revupgrade { action portlist opts } {
- set status [macports::revupgrade $opts]
- if {$status != 0} {
- print_tickets_url
- }
- return $status
-}
-
-
-proc action_version { action portlist opts } {
- if {![macports::ui_isset ports_quiet]} {
- puts -nonewline "Version: "
- }
- puts [macports::version]
- return 0
-}
-
-
-proc action_platform { action portlist opts } {
- if {![macports::ui_isset ports_quiet]} {
- puts -nonewline "Platform: "
- }
- puts "${macports::os_platform} ${macports::os_major} ${macports::os_arch}"
- return 0
-}
-
-
-proc action_dependents { action portlist opts } {
- if {[require_portlist portlist]} {
- return 1
- }
- set ilist {}
-
- registry::open_dep_map
-
- set status 0
- foreachport $portlist {
- set composite_version [composite_version $portversion [array get variations]]
- if { [catch {set ilist [registry::installed $portname $composite_version]} result] } {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "$result" 1 status
- } else {
- # choose the active version if there is one
- set index 0
- foreach i $ilist {
- if {[lindex $i 4]} {
- set found 1
- break
- }
- incr index
- }
- if {![info exists found]} {
- set index 0
- }
- # set portname again since the one we were passed may not have had the correct case
- set portname [lindex $ilist $index 0]
- set iversion [lindex $ilist $index 1]
- set irevision [lindex $ilist $index 2]
- set ivariants [lindex $ilist $index 3]
- }
-
- set deplist [registry::list_dependents $portname $iversion $irevision $ivariants]
- if { [llength $deplist] > 0 } {
- if {$action eq "rdependents"} {
- set toplist $deplist
- while 1 {
- set newlist {}
- foreach dep $deplist {
- set depname [lindex $dep 2]
- if {![info exists seen($depname)]} {
- set seen($depname) 1
- set rdeplist [registry::list_dependents $depname]
- foreach rdep $rdeplist {
- lappend newlist $rdep
- }
- set dependentsof($depname) $rdeplist
- }
- }
- if {[llength $newlist] > 0} {
- set deplist $newlist
- } else {
- break
- }
- }
- set portstack [list $toplist]
- set pos_stack [list 0]
- array unset seen
- ui_notice "The following ports are dependent on ${portname}:"
- while 1 {
- set cur_portlist [lindex $portstack end]
- set cur_pos [lindex $pos_stack end]
- if {$cur_pos >= [llength $cur_portlist]} {
- set portstack [lreplace $portstack end end]
- set pos_stack [lreplace $pos_stack end end]
- if {[llength $portstack] <= 0} {
- break
- } else {
- continue
- }
- }
- set cur_port [lindex $cur_portlist $cur_pos]
- set cur_portname [lindex $cur_port 2]
- set spaces [string repeat " " [expr {[llength $pos_stack] * 2}]]
- if {![info exists seen($cur_portname)] || ([info exists options(ports_rdependents_full)] && [string is true -strict $options(ports_rdependents_full)])} {
- puts "${spaces}${cur_portname}"
- set seen($cur_portname) 1
- incr cur_pos
- set pos_stack [lreplace $pos_stack end end $cur_pos]
- if {[info exists dependentsof($cur_portname)]} {
- lappend portstack $dependentsof($cur_portname)
- lappend pos_stack 0
- }
- continue
- }
- incr cur_pos
- set pos_stack [lreplace $pos_stack end end $cur_pos]
- }
- } else {
- foreach dep $deplist {
- set depport [lindex $dep 2]
- if {[macports::ui_isset ports_quiet]} {
- ui_msg "$depport"
- } elseif {![macports::ui_isset ports_verbose]} {
- ui_msg "$depport depends on $portname"
- } else {
- ui_msg "$depport depends on $portname (by [lindex $dep 1]:)"
- }
- }
- }
- } else {
- ui_notice "$portname has no dependents."
- }
- }
- return $status
-}
-
-
-proc action_deps { action portlist opts } {
- global global_variations
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
- set separator ""
-
- foreachport $portlist {
- if {[info exists options(ports_${action}_no-build)] && [string is true -strict $options(ports_${action}_no-build)]} {
- set deptypes {depends_lib depends_run}
- } else {
- set deptypes {depends_fetch depends_extract depends_build depends_lib depends_run}
- }
-
- array unset portinfo
- # If we have a url, use that, since it's most specific
- # otherwise try to map the portname to a url
- if {$porturl eq ""} {
- # Verify the portname, getting portinfo to map to a porturl
- if {[catch {mportlookup $portname} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Port $portname not found" 1 status
- }
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
- } elseif {$porturl ne "file://."} {
- # Extract the portdir from porturl and use it to search PortIndex.
- # Only the last two elements of the path (porturl) make up the
- # portdir.
- set portdir [file split [macports::getportdir $porturl]]
- set lsize [llength $portdir]
- set portdir \
- [file join [lindex $portdir [expr {$lsize - 2}]] \
- [lindex $portdir [expr {$lsize - 1}]]]
- if {[catch {mportsearch $portdir no exact portdir} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Portdir $portdir not found" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Portdir $portdir not found" 1 status
- }
- set matchindex [lsearch -exact -nocase $result $portname]
- if {$matchindex != -1} {
- array set portinfo [lindex $result [incr matchindex]]
- } else {
- ui_warn "Portdir $portdir doesn't seem to belong to portname $portname"
- array set portinfo [lindex $result 1]
- }
- }
-
- if {!([info exists options(ports_${action}_index)] && $options(ports_${action}_index) eq "yes")} {
- # Add any global_variations to the variations
- # specified for the port, so we get dependencies right
- array unset merged_variations
- array set merged_variations [array get variations]
- foreach { variation value } [array get global_variations] {
- if { ![info exists merged_variations($variation)] } {
- set merged_variations($variation) $value
- }
- }
- if {![info exists options(subport)]} {
- if {[info exists portinfo(name)]} {
- set options(subport) $portinfo(name)
- } else {
- set options(subport) $portname
- }
- }
- if {[catch {set mport [mportopen $porturl [array get options] [array get merged_variations]]} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Unable to open port: $result" 1 status
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
- } elseif {![info exists portinfo]} {
- ui_warn "port ${action} --index does not work with the 'current' pseudo-port"
- continue
- }
- set portname $portinfo(name)
-
- set deplist {}
- set deps_output {}
- set ndeps 0
- array set labeldict {depends_fetch Fetch depends_extract Extract depends_build Build depends_lib Library depends_run Runtime}
- # get list of direct deps
- foreach type $deptypes {
- if {[info exists portinfo($type)]} {
- if {$action eq "rdeps" || [macports::ui_isset ports_verbose]} {
- foreach dep $portinfo($type) {
- lappend deplist $dep
- }
- } else {
- foreach dep $portinfo($type) {
- lappend deplist [lindex [split $dep :] end]
- }
- }
- if {$action eq "deps"} {
- set label "$labeldict($type) Dependencies"
- lappend deps_output [wraplabel $label [join $deplist ", "] 0 [string repeat " " 22]]
- incr ndeps [llength $deplist]
- set deplist {}
- }
- }
- }
-
- set version $portinfo(version)
- set revision $portinfo(revision)
- if {[info exists portinfo(canonical_active_variants)]} {
- set variants $portinfo(canonical_active_variants)
- } else {
- set variants {}
- }
-
- puts -nonewline $separator
- if {$action eq "deps"} {
- if {$ndeps == 0} {
- ui_notice "$portname @${version}_${revision}${variants} has no dependencies."
- } else {
- ui_notice "Full Name: $portname @${version}_${revision}${variants}"
- puts [join $deps_output "\n"]
- }
- set separator "--\n"
- continue
- }
-
- set toplist $deplist
- # gather all the deps
- while 1 {
- set newlist {}
- foreach dep $deplist {
- set depname [lindex [split $dep :] end]
- if {![info exists seen($depname)]} {
- set seen($depname) 1
-
- # look up the dep
- if {[catch {mportlookup $depname} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "lookup of portname $depname failed: $result" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Port $depname not found" 1 status
- }
- array unset portinfo
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
- set options(subport) $portinfo(name)
-
- # open the portfile if requested
- if {!([info exists options(ports_${action}_index)] && $options(ports_${action}_index) eq "yes")} {
- if {[catch {set mport [mportopen $porturl [array get options] [array get merged_variations]]} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Unable to open port: $result" 1 status
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
- }
-
- # get list of the dep's deps
- set rdeplist {}
- foreach type $deptypes {
- if {[info exists portinfo($type)]} {
- foreach rdep $portinfo($type) {
- lappend rdeplist $rdep
- lappend newlist $rdep
- }
- }
- }
- set depsof($depname) $rdeplist
- }
- }
- if {[llength $newlist] > 0} {
- set deplist $newlist
- } else {
- break
- }
- }
- set portstack [list $toplist]
- set pos_stack [list 0]
- array unset seen
- if {[llength $toplist] > 0} {
- ui_notice "The following ports are dependencies of $portname @${version}_${revision}${variants}:"
- } else {
- ui_notice "$portname @${version}_${revision}${variants} has no dependencies."
- }
- while 1 {
- set cur_portlist [lindex $portstack end]
- set cur_pos [lindex $pos_stack end]
- if {$cur_pos >= [llength $cur_portlist]} {
- set portstack [lreplace $portstack end end]
- set pos_stack [lreplace $pos_stack end end]
- if {[llength $portstack] <= 0} {
- break
- } else {
- continue
- }
- }
- set cur_port [lindex $cur_portlist $cur_pos]
- set cur_portname [lindex [split $cur_port :] end]
- set spaces [string repeat " " [expr {[llength $pos_stack] * 2}]]
- if {![info exists seen($cur_portname)] || ([info exists options(ports_${action}_full)] && [string is true -strict $options(ports_${action}_full)])} {
- if {[macports::ui_isset ports_verbose]} {
- puts "${spaces}${cur_port}"
- } else {
- puts "${spaces}${cur_portname}"
- }
- set seen($cur_portname) 1
- incr cur_pos
- set pos_stack [lreplace $pos_stack end end $cur_pos]
- if {[info exists depsof($cur_portname)]} {
- lappend portstack $depsof($cur_portname)
- lappend pos_stack 0
- }
- continue
- }
- incr cur_pos
- set pos_stack [lreplace $pos_stack end end $cur_pos]
- }
- set separator "--\n"
- }
- return $status
-}
-
-
-proc action_uninstall { action portlist opts } {
- set status 0
- if {[macports::global_option_isset port_uninstall_old]} {
- # if -u then uninstall all inactive ports
- # (union these to any other ports user has in the port list)
- set portlist [opUnion $portlist [get_inactive_ports]]
- } else {
- # Otherwise the user hopefully supplied a portlist, or we'll default to the existing directory
- if {[require_portlist portlist]} {
- return 1
- }
- }
- if {[prefix_unwritable]} {
- return 1
- }
-
- set portlist [portlist_sortdependents $portlist]
-
- foreachport $portlist {
- if {![registry::entry_exists_for_name $portname]} {
- # if the code path arrives here the port either isn't installed, or
- # it doesn't exist at all. We can't be sure, but we can check the
- # portindex whether a port by that name exists (in which case not
- # uninstalling it is probably no problem). If there is no port by
- # that name, alert the user in case of typos.
- ui_info "$portname is not installed"
- if {[catch {set res [mportlookup $portname]} result] || [llength $res] == 0} {
- ui_warn "no such port: $portname, skipping uninstall"
- }
- continue
- }
- set composite_version [composite_version $portversion [array get variations]]
- if {![info exists options(ports_uninstall_no-exec)]
- && ![catch {set ilist [registry::installed $portname $composite_version]}]
- && [llength $ilist] == 1} {
-
- set i [lindex $ilist 0]
- set iactive [lindex $i 4]
- set regref [registry::entry open $portname [lindex $i 1] [lindex $i 2] [lindex $i 3] [lindex $i 5]]
- if {[registry::run_target $regref uninstall [array get options]]} {
- continue
- }
- }
-
- if { [catch {registry_uninstall::uninstall_composite $portname $composite_version [array get options]} result] } {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port uninstall failed: $result" 1 status
- }
- }
-
- return $status
-}
-
-
-proc action_installed { action portlist opts } {
- global private_options
- set status 0
- set restrictedList 0
- set ilist {}
-
- if { [llength $portlist] || (![info exists private_options(ports_no_args)] || $private_options(ports_no_args) eq "no")} {
- set restrictedList 1
- foreachport $portlist {
- set composite_version [composite_version $portversion [array get variations]]
- if { [catch {set ilist [concat $ilist [registry::installed $portname $composite_version]]} result] } {
- if {![string match "* not registered as installed." $result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port installed failed: $result" 1 status
- }
- }
- }
- } else {
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- ui_error "port installed failed: $result"
- set status 1
- }
- }
- }
- if { [llength $ilist] > 0 } {
- ui_notice "The following ports are currently installed:"
- foreach i [portlist_sortint $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]
- set extra ""
- set nvariants ""
- if {[macports::ui_isset ports_verbose]} {
- set regref [registry::open_entry $iname $iversion $irevision $ivariants [lindex $i 5]]
- set nvariants [registry::property_retrieve $regref negated_variants]
- if {$nvariants == 0} {
- set nvariants ""
- }
- set os_platform [registry::property_retrieve $regref os_platform]
- set os_major [registry::property_retrieve $regref os_major]
- set archs [registry::property_retrieve $regref archs]
- if {$os_platform != 0 && $os_platform ne "" && $os_major != 0 && $os_major ne ""} {
- append extra " platform='$os_platform $os_major'"
- }
- if {$archs != 0 && $archs ne ""} {
- append extra " archs='$archs'"
- }
- }
- if { $iactive == 0 } {
- puts " $iname @${iversion}_${irevision}${ivariants}${nvariants}${extra}"
- } elseif { $iactive == 1 } {
- puts " $iname @${iversion}_${irevision}${ivariants}${nvariants} (active)${extra}"
- }
- }
- } elseif { $restrictedList } {
- ui_notice "None of the specified ports are installed."
- } else {
- ui_notice "No ports are installed."
- }
-
- return $status
-}
-
-
-proc action_outdated { action portlist opts } {
- global private_options
- set status 0
-
- # If port names were supplied, limit ourselves to those ports, else check all installed ports
- set ilist {}
- set restrictedList 0
- if { [llength $portlist] || (![info exists private_options(ports_no_args)] || $private_options(ports_no_args) eq "no")} {
- set restrictedList 1
- foreach portspec $portlist {
- array set port $portspec
- set portname $port(name)
- set composite_version [composite_version $port(version) $port(variants)]
- if { [catch {set ilist [concat $ilist [registry::installed $portname $composite_version]]} result] } {
- if {![string match "* not registered as installed." $result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port outdated failed: $result" 1 status
- }
- }
- }
- } else {
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- ui_error "port installed failed: $result"
- set status 1
- }
- }
- }
-
- set num_outdated 0
- if { [llength $ilist] > 0 } {
- foreach i [portlist_sortint $ilist] {
-
- # Get information about the installed port
- set portname [lindex $i 0]
- set installed_version [lindex $i 1]
- set installed_revision [lindex $i 2]
- set installed_compound "${installed_version}_${installed_revision}"
-
- set is_active [lindex $i 4]
- if {$is_active == 0} {
- continue
- }
- set installed_epoch [lindex $i 5]
-
- # Get info about the port from the index
- if {[catch {set res [mportlookup $portname]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "search for portname $portname failed: $result" 1 status
- }
- if {[llength $res] < 2} {
- if {[macports::ui_isset ports_debug]} {
- puts "$portname ($installed_compound is installed; the port was not found in the port index)"
- }
- continue
- }
- array unset portinfo
- array set portinfo [lindex $res 1]
-
- # Get information about latest available version and revision
- if {![info exists portinfo(version)]} {
- ui_warn "$portname has no version field"
- continue
- }
- set latest_version $portinfo(version)
- set latest_revision 0
- if {[info exists portinfo(revision)] && $portinfo(revision) > 0} {
- set latest_revision $portinfo(revision)
- }
- set latest_compound "${latest_version}_${latest_revision}"
- set latest_epoch 0
- if {[info exists portinfo(epoch)]} {
- set latest_epoch $portinfo(epoch)
- }
-
- # Compare versions, first checking epoch, then version, then revision
- set epoch_comp_result [expr {$installed_epoch - $latest_epoch}]
- set comp_result [vercmp $installed_version $latest_version]
- if { $comp_result == 0 } {
- set comp_result [expr {$installed_revision - $latest_revision}]
- }
- set reason ""
- if {$epoch_comp_result != 0 && $installed_version != $latest_version} {
- if {($comp_result >= 0 && $epoch_comp_result < 0) || ($comp_result <= 0 && $epoch_comp_result > 0)} {
- set reason { (epoch $installed_epoch $relation $latest_epoch)}
- }
- set comp_result $epoch_comp_result
- } elseif {$comp_result == 0} {
- set regref [registry::open_entry $portname $installed_version $installed_revision [lindex $i 3] $installed_epoch]
- set os_platform_installed [registry::property_retrieve $regref os_platform]
- set os_major_installed [registry::property_retrieve $regref os_major]
- if {$os_platform_installed ne "" && $os_platform_installed != 0
- && $os_major_installed ne "" && $os_major_installed != 0
- && ($os_platform_installed != ${macports::os_platform} || $os_major_installed != ${macports::os_major})} {
- set comp_result -1
- set reason { (platform $os_platform_installed $os_major_installed != ${macports::os_platform} ${macports::os_major})}
- }
- }
-
- # Report outdated (or, for verbose, predated) versions
- if { $comp_result != 0 } {
-
- # Form a relation between the versions
- set flag ""
- if { $comp_result > 0 } {
- set relation ">"
- set flag "!"
- } else {
- set relation "<"
- }
-
- # Emit information
- if {$comp_result < 0 || [macports::ui_isset ports_verbose]} {
-
- if {$num_outdated == 0} {
- ui_notice "The following installed ports are outdated:"
- }
- incr num_outdated
-
- puts [format "%-30s %-24s %1s" $portname "$installed_compound $relation $latest_compound [subst $reason]" $flag]
- }
-
- }
- }
-
- if {$num_outdated == 0} {
- ui_notice "No installed ports are outdated."
- }
- } elseif { $restrictedList } {
- ui_notice "None of the specified ports are outdated."
- } else {
- ui_notice "No ports are installed."
- }
-
- return $status
-}
-
-
-proc action_contents { action portlist opts } {
- global global_options
- if {[require_portlist portlist]} {
- return 1
- }
- if {[info exists global_options(ports_contents_size)]} {
- set units {}
- if {[info exists global_options(ports_contents_units)]} {
- set units [complete_size_units $global_options(ports_contents_units)]
- }
- set outstring {[format "%12s $file" [filesize $file $units]]}
- } else {
- set outstring { $file}
- }
-
- foreachport $portlist {
- if { ![catch {set ilist [registry::installed $portname]} result] } {
- # set portname again since the one we were passed may not have had the correct case
- set portname [lindex $ilist 0 0]
- }
- set files [registry::port_registered $portname]
- if { $files != 0 } {
- if { [llength $files] > 0 } {
- ui_notice "Port $portname contains:"
- foreach file $files {
- puts [subst $outstring]
- }
- } else {
- ui_notice "Port $portname does not contain any files or is not active."
- }
- } else {
- ui_notice "Port $portname is not installed."
- }
- }
- registry::close_file_map
-
- return 0
-}
-
-# expand abbreviations of size units
-proc complete_size_units {units} {
- if {$units eq "K" || $units eq "Ki"} {
- return "KiB"
- } elseif {$units eq "k"} {
- return "kB"
- } elseif {$units eq "Mi"} {
- return "MiB"
- } elseif {$units eq "M"} {
- return "MB"
- } elseif {$units eq "Gi"} {
- return "GiB"
- } elseif {$units eq "G"} {
- return "GB"
- } else {
- return $units
- }
-}
-
-# Show space used by the given ports' files
-proc action_space {action portlist opts} {
- global global_options
- require_portlist portlist
-
- set units {}
- if {[info exists global_options(ports_space_units)]} {
- set units [complete_size_units $global_options(ports_space_units)]
- }
- set spaceall 0.0
- foreachport $portlist {
- set space 0.0
- set files [registry::port_registered $portname]
- if { $files != 0 } {
- if { [llength $files] > 0 } {
- foreach file $files {
- catch {
- set space [expr {$space + [file size $file]}]
- }
- }
- if {![info exists options(ports_space_total)] || $options(ports_space_total) ne "yes"} {
- set msg "[bytesize $space $units] $portname"
- if { $portversion != {} } {
- append msg " @$portversion"
- }
- puts $msg
- }
- set spaceall [expr {$space + $spaceall}]
- } else {
- puts stderr "Port $portname does not contain any file or is not active."
- }
- } else {
- puts stderr "Port $portname is not installed."
- }
- }
- if {[llength $portlist] > 1 || ([info exists options(ports_space_total)] && $options(ports_space_total) eq "yes")} {
- puts "[bytesize $spaceall $units] total"
- }
- return 0
-}
-
-proc action_variants { action portlist opts } {
- global global_variations
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
- foreachport $portlist {
- array unset portinfo
- if {$porturl eq ""} {
- # look up port
- if {[catch {mportlookup $portname} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Port $portname not found" 1 status
- }
-
- array set portinfo [lindex $result 1]
-
- set porturl $portinfo(porturl)
- set portdir $portinfo(portdir)
- }
-
- if {!([info exists options(ports_variants_index)] && $options(ports_variants_index) eq "yes")} {
- if {![info exists options(subport)]} {
- if {[info exists portinfo(name)]} {
- set options(subport) $portinfo(name)
- } else {
- set options(subport) $portname
- }
- }
- if {[catch {set mport [mportopen $porturl [array get options] [array get variations]]} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Unable to open port: $result" 1 status
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
- if {[info exists portdir]} {
- set portinfo(portdir) $portdir
- }
- } elseif {![info exists portinfo]} {
- ui_warn "port variants --index does not work with 'current' pseudo-port"
- continue
- }
-
- # set portname again since the one we were passed may not have had the correct case
- set portname $portinfo(name)
-
- # if this fails the port doesn't have any variants
- if {![info exists portinfo(variants)]} {
- ui_notice "$portname has no variants"
- } else {
- array unset vinfo
- # Use the new format if it exists.
- if {[info exists portinfo(vinfo)]} {
- array set vinfo $portinfo(vinfo)
- # Otherwise fall back to the old format.
- } elseif {[info exists portinfo(variant_desc)]} {
- array set vdescriptions $portinfo(variant_desc)
- }
-
- # print out all the variants
- ui_notice "$portname has the variants:"
- foreach v [lsort $portinfo(variants)] {
- unset -nocomplain vconflicts vdescription vrequires
- set varmodifier " "
- # Retrieve variants' information from the new format.
- if {[info exists vinfo]} {
- array unset variant
- array set variant $vinfo($v)
-
- # Retrieve conflicts, description, is_default, and
- # vrequires.
- if {[info exists variant(conflicts)]} {
- set vconflicts $variant(conflicts)
- }
- if {[info exists variant(description)]} {
- set vdescription $variant(description)
- }
-
- # XXX Keep these varmodifiers in sync with action_info, or create a wrapper for it
- if {[info exists variations($v)]} {
- set varmodifier " $variations($v)"
- } elseif {[info exists global_variations($v)]} {
- # selected by variants.conf, prefixed with (+)/(-)
- set varmodifier "($global_variations($v))"
- } elseif {[info exists variant(is_default)]} {
- set varmodifier "\[$variant(is_default)\]"
- }
- if {[info exists variant(requires)]} {
- set vrequires $variant(requires)
- }
- # Retrieve variants' information from the old format,
- # which only consists of the description.
- } elseif {[info exists vdescriptions($v)]} {
- set vdescription $vdescriptions($v)
- }
-
- if {[info exists vdescription]} {
- puts [wraplabel "$varmodifier$v" [string trim $vdescription] 0 [string repeat " " [expr 5 + [string length $v]]]]
- } else {
- puts "$varmodifier$v"
- }
- if {[info exists vconflicts]} {
- puts " * conflicts with [string trim $vconflicts]"
- }
- if {[info exists vrequires]} {
- puts " * requires [string trim $vrequires]"
- }
- }
- }
- }
-
- return $status
-}
-
-
-proc action_search { action portlist opts } {
- global private_options global_options
- set status 0
- if {![llength $portlist] && [info exists private_options(ports_no_args)] && $private_options(ports_no_args) eq "yes"} {
- ui_error "You must specify a search pattern"
- return 1
- }
-
- # Copy global options as we are going to modify the array
- array set options [array get global_options]
-
- if {[info exists options(ports_search_depends)] && $options(ports_search_depends) eq "yes"} {
- array unset options ports_search_depends
- set options(ports_search_depends_fetch) yes
- set options(ports_search_depends_extract) yes
- set options(ports_search_depends_build) yes
- set options(ports_search_depends_lib) yes
- set options(ports_search_depends_run) yes
- }
-
- # Array to hold given filters
- array set filters {}
- # Default matchstyle
- set filter_matchstyle "none"
- set filter_case no
- foreach { option } [array names options ports_search_*] {
- set opt [string range $option 13 end]
-
- if { $options($option) ne "yes" } {
- continue
- }
- switch -- $opt {
- exact -
- glob {
- set filter_matchstyle $opt
- continue
- }
- regex {
- set filter_matchstyle regexp
- continue
- }
- case-sensitive {
- set filter_case yes
- continue
- }
- line {
- continue
- }
- }
-
- set filters($opt) "yes"
- }
- # Set default search filter if none was given
- if { [array size filters] == 0 } {
- set filters(name) "yes"
- set filters(description) "yes"
- }
-
- set separator ""
- foreach portname $portlist {
- puts -nonewline $separator
-
- set searchstring $portname
- set matchstyle $filter_matchstyle
- if {$matchstyle eq "none"} {
- # Guess if the given string was a glob expression, if not do a substring search
- if {[string first "*" $portname] == -1 && [string first "?" $portname] == -1} {
- set searchstring "*$portname*"
- }
- set matchstyle glob
- }
-
- set res {}
- set portfound 0
- foreach { opt } [array get filters] {
- # Map from friendly name
- set opt [map_friendly_field_names $opt]
-
- if {[catch {eval set matches \[mportsearch \$searchstring $filter_case \$matchstyle $opt\]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "search for name $portname failed: $result" 1 status
- }
-
- set tmp {}
- foreach {name info} $matches {
- add_to_portlist tmp [concat [list name $name] $info]
- }
- set res [opUnion $res $tmp]
- }
- set res [portlist_sort $res]
-
- set joiner ""
- foreach info $res {
- array unset portinfo
- array set portinfo $info
-
- # XXX is this the right place to verify an entry?
- if {![info exists portinfo(name)]} {
- puts stderr "Invalid port entry, missing portname"
- continue
- }
- if {![info exists portinfo(description)]} {
- puts stderr "Invalid port entry for $portinfo(name), missing description"
- continue
- }
- if {![info exists portinfo(version)]} {
- puts stderr "Invalid port entry for $portinfo(name), missing version"
- continue
- }
-
- if {[macports::ui_isset ports_quiet]} {
- puts $portinfo(name)
- } else {
- if {[info exists options(ports_search_line)]
- && $options(ports_search_line) eq "yes"} {
- # check for ports without category, e.g. replaced_by stubs
- if {[info exists portinfo(categories)]} {
- puts "$portinfo(name)\t$portinfo(version)\t$portinfo(categories)\t$portinfo(description)"
- } else {
- # keep two consecutive tabs in order to provide consistent columns' content
- puts "$portinfo(name)\t$portinfo(version)\t\t$portinfo(description)"
- }
- } else {
- puts -nonewline $joiner
-
- puts -nonewline "$portinfo(name) @$portinfo(version)"
- if {[info exists portinfo(revision)] && $portinfo(revision) > 0} {
- puts -nonewline "_$portinfo(revision)"
- }
- if {[info exists portinfo(categories)]} {
- puts -nonewline " ([join $portinfo(categories) ", "])"
- }
- puts ""
- puts [wrap [join $portinfo(description)] 0 [string repeat " " 4]]
- }
- }
-
- set joiner "\n"
- set portfound 1
- }
- if { !$portfound } {
- ui_notice "No match for $portname found"
- } elseif {[llength $res] > 1} {
- if {(![info exists global_options(ports_search_line)]
- || $global_options(ports_search_line) ne "yes")} {
- ui_notice "\nFound [llength $res] ports."
- }
- }
-
- set separator "--\n"
- }
-
- array unset options
- array unset filters
-
- return $status
-}
-
-
-proc action_list { action portlist opts } {
- global private_options
- set status 0
-
- # Default to list all ports if no portnames are supplied
- if { ![llength $portlist] && [info exists private_options(ports_no_args)] && $private_options(ports_no_args) eq "yes"} {
- add_to_portlist portlist [list name "-all-"]
- }
-
- foreachport $portlist {
- if {$portname eq "-all-"} {
- if {[catch {set res [mportlistall]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "listing all ports failed: $result" 1 status
- }
- } else {
- set search_string [regex_pat_sanitize $portname]
- if {[catch {set res [mportsearch ^$search_string\$ no]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "search for portname $search_string failed: $result" 1 status
- }
- }
-
- foreach {name array} $res {
- array unset portinfo
- array set portinfo $array
- set outdir ""
- if {[info exists portinfo(portdir)]} {
- set outdir $portinfo(portdir)
- }
- puts [format "%-30s @%-14s %s" $portinfo(name) $portinfo(version) $outdir]
- }
- }
-
- return $status
-}
-
-
-proc action_echo { action portlist opts } {
- global global_options
-
- # Simply echo back the port specs given to this command
- foreachport $portlist {
- if {![macports::ui_isset ports_quiet]} {
- set opts {}
- foreach { key value } [array get options] {
- if {![info exists global_options($key)]} {
- lappend opts "$key=$value"
- }
- }
-
- set composite_version [composite_version $portversion [array get variations] 1]
- if { $composite_version ne "" } {
- set ver_field "@$composite_version"
- } else {
- set ver_field ""
- }
- puts [format "%-30s %s %s" $portname $ver_field [join $opts " "]]
- } else {
- puts "$portname"
- }
- }
-
- return 0
-}
-
-
-proc action_portcmds { action portlist opts } {
- # Operations on the port's directory and Portfile
- global env boot_env current_portdir
-
- array set local_options $opts
-
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
- foreachport $portlist {
- array unset portinfo
- # If we have a url, use that, since it's most specific, otherwise try to map the portname to a url
- if {$porturl eq ""} {
-
- # Verify the portname, getting portinfo to map to a porturl
- if {[catch {set res [mportlookup $portname]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $res] < 2} {
- break_softcontinue "Port $portname not found" 1 status
- }
- array set portinfo [lindex $res 1]
- set porturl $portinfo(porturl)
- set portname $portinfo(name)
- }
-
-
- # Calculate portdir, porturl, and portfile from initial porturl
- set portdir [file normalize [macports::getportdir $porturl]]
- set porturl "file://${portdir}"; # Rebuild url so it's fully qualified
- set portfile "${portdir}/Portfile"
-
- # Now execute the specific action
- if {[file readable $portfile]} {
- switch -- $action {
- cat {
- # Copy the portfile to standard output
- set f [open $portfile RDONLY]
- while { ![eof $f] } {
- puts -nonewline [read $f 4096]
- }
- close $f
- }
-
- edit {
- # Edit the port's portfile with the user's editor
-
- # Restore our entire environment from start time.
- # We need it to evaluate the editor, and the editor
- # may want stuff from it as well, like TERM.
- array unset env_save; array set env_save [array get env]
- array unset env *
- if {${macports::macosx_version} eq "10.5"} {
- unsetenv *
- }
- array set env [array get boot_env]
-
- # Find an editor to edit the portfile
- set editor ""
- set editor_var "ports_${action}_editor"
- if {[info exists local_options($editor_var)]} {
- set editor [join $local_options($editor_var)]
- } else {
- foreach ed { MP_EDITOR VISUAL EDITOR } {
- if {[info exists env($ed)]} {
- set editor $env($ed)
- break
- }
- }
- }
-
- # Use a reasonable canned default if no editor specified or set in env
- if { $editor eq "" } { set editor "/usr/bin/vi" }
-
- # Invoke the editor
- if {[catch {eval exec >@stdout <@stdin 2>@stderr $editor {$portfile}} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "unable to invoke editor $editor: $result" 1 status
- }
-
- # Restore internal MacPorts environment
- array unset env *
- if {${macports::macosx_version} eq "10.5"} {
- unsetenv *
- }
- array set env [array get env_save]
- }
-
- dir {
- # output the path to the port's directory
- puts $portdir
- }
-
- work {
- # output the path to the port's work directory
- set workpath [macports::getportworkpath_from_portdir $portdir $portname]
- if {[file exists $workpath]} {
- puts $workpath
- }
- }
-
- cd {
- # Change to the port's directory, making it the default
- # port for any future commands
- set current_portdir $portdir
- }
-
- url {
- # output the url of the port's directory, suitable to feed back in later as a port descriptor
- puts $porturl
- }
-
- file {
- # output the path to the port's portfile
- puts $portfile
- }
-
- logfile {
- set logfile [file join [macports::getportlogpath $portdir $portname] "main.log"]
- if {[file isfile $logfile]} {
- puts $logfile
- } else {
- ui_error "Log file not found for port in $portdir"
- }
- }
-
- gohome {
- set homepage ""
-
- # Get the homepage as read from PortIndex
- if {[info exists portinfo(homepage)]} {
- set homepage $portinfo(homepage)
- }
-
- # If not available, get the homepage for the port by opening the Portfile
- if {$homepage eq "" && ![catch {set ctx [mportopen $porturl]} result]} {
- array set portinfo [mportinfo $ctx]
- if {[info exists portinfo(homepage)]} {
- set homepage $portinfo(homepage)
- }
- mportclose $ctx
- }
-
- # Try to open a browser to the homepage for the given port
- if { $homepage ne "" } {
- if {[catch {system "${macports::autoconf::open_path} '$homepage'"} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "unable to invoke browser using ${macports::autoconf::open_path}: $result" 1 status
- }
- } else {
- ui_error [format "No homepage for %s" $portname]
- }
- }
- }
- } else {
- break_softcontinue "Could not read $portfile" 1 status
- }
- }
-
- return $status
-}
-
-
-proc action_sync { action portlist opts } {
- global global_options
-
- set status 0
- if {[catch {mportsync [array get global_options]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- ui_msg "port sync failed: $result"
- set status 1
- }
-
- return $status
-}
-
-
-proc action_target { action portlist opts } {
- global global_variations
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
- if {($action eq "install" || $action eq "archive") && [prefix_unwritable] && ![macports::global_option_isset ports_dryrun]} {
- return 1
- }
- foreachport $portlist {
- array unset portinfo
- # If we have a url, use that, since it's most specific
- # otherwise try to map the portname to a url
- if {$porturl eq ""} {
- # Verify the portname, getting portinfo to map to a porturl
- if {[catch {set res [mportlookup $portname]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $res] < 2} {
- # don't error for ports that are installed but not in the tree
- if {[registry::entry_exists_for_name $portname]} {
- ui_warn "Skipping $portname (not in the ports tree)"
- continue
- } else {
- break_softcontinue "Port $portname not found" 1 status
- }
- }
- array set portinfo [lindex $res 1]
- set porturl $portinfo(porturl)
- }
-
- # use existing variants iff none were explicitly requested
- if {[array get requested_variations] eq "" && [array get variations] ne ""} {
- array unset requested_variations
- array set requested_variations [array get variations]
- }
-
- # Add any global_variations to the variations
- # specified for the port
- foreach { variation value } [array get global_variations] {
- if { ![info exists requested_variations($variation)] } {
- set requested_variations($variation) $value
- }
- }
-
- # If version was specified, save it as a version glob for use
- # in port actions (e.g. clean).
- if {[string length $portversion]} {
- set options(ports_version_glob) $portversion
- }
- # if installing, mark the port as explicitly requested
- if {$action eq "install"} {
- if {![info exists options(ports_install_unrequested)]} {
- set options(ports_requested) 1
- }
- # we actually activate as well
- set target activate
- } elseif {$action eq "archive"} {
- set target install
- } else {
- set target $action
- }
- if {![info exists options(subport)]} {
- if {[info exists portinfo(name)]} {
- set options(subport) $portinfo(name)
- } else {
- set options(subport) $portname
- }
- }
- if {[catch {set workername [mportopen $porturl [array get options] [array get requested_variations]]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "Unable to open port: $result" 1 status
- }
- if {[catch {set result [mportexec $workername $target]} result]} {
- global errorInfo
- mportclose $workername
- ui_debug "$errorInfo"
- break_softcontinue "Unable to execute port: $result" 1 status
- }
-
- mportclose $workername
-
- # Process any error that wasn't thrown and handled already
- if {$result} {
- print_tickets_url
- break_softcontinue "Processing of port $portname failed" 1 status
- }
- }
-
- if {$status == 0 && $action eq "install" && ![macports::global_option_isset ports_dryrun]} {
- array set options $opts
- if {![info exists options(ports_nodeps)] && ![info exists options(ports_install_no-rev-upgrade)] && ${macports::revupgrade_autorun}} {
- set status [action_revupgrade $action $portlist $opts]
- }
- }
-
- return $status
-}
-
-
-proc action_exit { action portlist opts } {
- # Return a semaphore telling the main loop to quit
- return -999
-}
-
-
-##########################################
-# Command Parsing
-##########################################
-proc moreargs {} {
- global cmd_argn cmd_argc
- return [expr {$cmd_argn < $cmd_argc}]
-}
-
-
-proc lookahead {} {
- global cmd_argn cmd_argc cmd_argv
- if {$cmd_argn < $cmd_argc} {
- return [lindex $cmd_argv $cmd_argn]
- } else {
- return _EOF_
- }
-}
-
-
-proc advance {} {
- global cmd_argn
- incr cmd_argn
-}
-
-
-proc match s {
- if {[lookahead] == $s} {
- advance
- return 1
- }
- return 0
-}
-
-# action_array specifies which action to run on the given command
-# and if the action wants an expanded portlist.
-# The value is a list of the form {action expand},
-# where action is a string and expand a value:
-# 0 none Does not expect any text argument
-# 1 strings Expects some strings as text argument
-# 2 ports Wants an expanded list of ports as text argument
-global action_array
-
-# Define global constants
-const ACTION_ARGS_NONE 0
-const ACTION_ARGS_STRINGS 1
-const ACTION_ARGS_PORTS 2
-
-array set action_array [list \
- usage [list action_usage [ACTION_ARGS_STRINGS]] \
- help [list action_help [ACTION_ARGS_STRINGS]] \
- \
- echo [list action_echo [ACTION_ARGS_PORTS]] \
- \
- info [list action_info [ACTION_ARGS_PORTS]] \
- location [list action_location [ACTION_ARGS_PORTS]] \
- notes [list action_notes [ACTION_ARGS_PORTS]] \
- provides [list action_provides [ACTION_ARGS_STRINGS]] \
- log [list action_log [ACTION_ARGS_PORTS]] \
- \
- activate [list action_activate [ACTION_ARGS_PORTS]] \
- deactivate [list action_deactivate [ACTION_ARGS_PORTS]] \
- \
- select [list action_select [ACTION_ARGS_STRINGS]] \
- \
- sync [list action_sync [ACTION_ARGS_NONE]] \
- selfupdate [list action_selfupdate [ACTION_ARGS_NONE]] \
- \
- setrequested [list action_setrequested [ACTION_ARGS_PORTS]] \
- unsetrequested [list action_setrequested [ACTION_ARGS_PORTS]] \
- \
- upgrade [list action_upgrade [ACTION_ARGS_PORTS]] \
- rev-upgrade [list action_revupgrade [ACTION_ARGS_NONE]] \
- reclaim [list action_reclaim [ACTION_ARGS_NONE]] \
- doctor [list action_doctor [ACTION_ARGS_NONE]] \
- \
- version [list action_version [ACTION_ARGS_NONE]] \
- platform [list action_platform [ACTION_ARGS_NONE]] \
- \
- uninstall [list action_uninstall [ACTION_ARGS_PORTS]] \
- \
- installed [list action_installed [ACTION_ARGS_PORTS]] \
- outdated [list action_outdated [ACTION_ARGS_PORTS]] \
- contents [list action_contents [ACTION_ARGS_PORTS]] \
- space [list action_space [ACTION_ARGS_PORTS]] \
- dependents [list action_dependents [ACTION_ARGS_PORTS]] \
- rdependents [list action_dependents [ACTION_ARGS_PORTS]] \
- deps [list action_deps [ACTION_ARGS_PORTS]] \
- rdeps [list action_deps [ACTION_ARGS_PORTS]] \
- variants [list action_variants [ACTION_ARGS_PORTS]] \
- \
- search [list action_search [ACTION_ARGS_STRINGS]] \
- list [list action_list [ACTION_ARGS_PORTS]] \
- \
- edit [list action_portcmds [ACTION_ARGS_PORTS]] \
- cat [list action_portcmds [ACTION_ARGS_PORTS]] \
- dir [list action_portcmds [ACTION_ARGS_PORTS]] \
- work [list action_portcmds [ACTION_ARGS_PORTS]] \
- cd [list action_portcmds [ACTION_ARGS_PORTS]] \
- url [list action_portcmds [ACTION_ARGS_PORTS]] \
- file [list action_portcmds [ACTION_ARGS_PORTS]] \
- logfile [list action_portcmds [ACTION_ARGS_PORTS]] \
- gohome [list action_portcmds [ACTION_ARGS_PORTS]] \
- \
- fetch [list action_target [ACTION_ARGS_PORTS]] \
- checksum [list action_target [ACTION_ARGS_PORTS]] \
- extract [list action_target [ACTION_ARGS_PORTS]] \
- patch [list action_target [ACTION_ARGS_PORTS]] \
- configure [list action_target [ACTION_ARGS_PORTS]] \
- build [list action_target [ACTION_ARGS_PORTS]] \
- destroot [list action_target [ACTION_ARGS_PORTS]] \
- install [list action_target [ACTION_ARGS_PORTS]] \
- clean [list action_target [ACTION_ARGS_PORTS]] \
- test [list action_target [ACTION_ARGS_PORTS]] \
- lint [list action_target [ACTION_ARGS_PORTS]] \
- livecheck [list action_target [ACTION_ARGS_PORTS]] \
- distcheck [list action_target [ACTION_ARGS_PORTS]] \
- mirror [list action_target [ACTION_ARGS_PORTS]] \
- load [list action_target [ACTION_ARGS_PORTS]] \
- unload [list action_target [ACTION_ARGS_PORTS]] \
- distfiles [list action_target [ACTION_ARGS_PORTS]] \
- \
- archivefetch [list action_target [ACTION_ARGS_PORTS]] \
- archive [list action_target [ACTION_ARGS_PORTS]] \
- unarchive [list action_target [ACTION_ARGS_PORTS]] \
- dmg [list action_target [ACTION_ARGS_PORTS]] \
- mdmg [list action_target [ACTION_ARGS_PORTS]] \
- dpkg [list action_target [ACTION_ARGS_PORTS]] \
- mpkg [list action_target [ACTION_ARGS_PORTS]] \
- pkg [list action_target [ACTION_ARGS_PORTS]] \
- portpkg [list action_target [ACTION_ARGS_PORTS]] \
- rpm [list action_target [ACTION_ARGS_PORTS]] \
- srpm [list action_target [ACTION_ARGS_PORTS]] \
- \
- quit [list action_exit [ACTION_ARGS_NONE]] \
- exit [list action_exit [ACTION_ARGS_NONE]] \
-]
-
-# Expand "action".
-# Returns an action proc, or a list of matching action procs, or the action passed in
-proc find_action { action } {
- global action_array
-
- if { ! [info exists action_array($action)] } {
- set guess [guess_action $action]
- if { [info exists action_array($guess)] } {
- return $guess
- }
- return $guess
- }
-
- return $action
-}
-
-# Expand action
-# If there's more than one match, return the next possibility
-proc find_action_proc { action } {
- global action_array
-
- set action_proc ""
- if { [info exists action_array($action)] } {
- set action_proc [lindex $action_array($action) 0]
- } else {
- set action [complete_action $action]
- if { [info exists action_array($action)] } {
- set action_proc [lindex $action_array($action) 0]
- }
- }
-
- return $action_proc
-}
-
-proc get_action_proc { action } {
- global action_array
-
- set action_proc ""
- if { [info exists action_array($action)] } {
- set action_proc [lindex $action_array($action) 0]
- }
-
- return $action_proc
-}
-
-# Returns whether an action expects text arguments at all,
-# expects text arguments or wants an expanded list of ports
-# Return values are constants:
-# [ACTION_ARGS_NONE] Does not expect any text argument
-# [ACTION_ARGS_STRINGS] Expects some strings as text argument
-# [ACTION_ARGS_PORTS] Wants an expanded list of ports as text argument
-proc action_needs_portlist { action } {
- global action_array
-
- set ret 0
- if {[info exists action_array($action)]} {
- set ret [lindex $action_array($action) 1]
- }
-
- return $ret
-}
-
-# cmd_opts_array specifies which arguments the commands accept
-# Commands not listed here do not accept any arguments
-# Syntax if {option argn}
-# Where option is the name of the option and argn specifies how many arguments
-# this argument takes
-global cmd_opts_array
-array set cmd_opts_array {
- edit {{editor 1}}
- info {category categories depends_fetch depends_extract
- depends_build depends_lib depends_run
- depends description epoch fullname heading homepage index license
- line long_description
- maintainer maintainers name platform platforms portdir pretty
- replaced_by revision subports variant variants version}
- contents {size {units 1}}
- deps {index no-build}
- rdeps {index no-build full}
- rdependents {full}
- search {case-sensitive category categories depends_fetch
- depends_extract depends_build depends_lib depends_run
- depends description epoch exact glob homepage line
- long_description maintainer maintainers name platform
- platforms portdir regex revision variant variants version}
- selfupdate {nosync}
- space {{units 1} total}
- activate {no-exec}
- deactivate {no-exec}
- install {no-rev-upgrade unrequested}
- uninstall {follow-dependents follow-dependencies no-exec}
- variants {index}
- clean {all archive dist work logs}
- mirror {new}
- lint {nitpick}
- select {list set show summary}
- log {{phase 1} {level 1}}
- upgrade {force enforce-variants no-replace no-rev-upgrade}
- rev-upgrade {id-loadcmd-check}
- doctor {quiet}
-}
-
-##
-# Checks whether the given option is valid
-#
-# @param action for which action
-# @param option the prefix of the option to check
-# @return list of pairs {name argc} for all matching options
-proc cmd_option_matches {action option} {
- global cmd_opts_array
-
- # This could be so easy with lsearch -index,
- # but that's only available as of Tcl 8.5
-
- if {![info exists cmd_opts_array($action)]} {
- return {}
- }
-
- set result {}
-
- foreach item $cmd_opts_array($action) {
- if {[llength $item] == 1} {
- set name $item
- set argc 0
- } else {
- set name [lindex $item 0]
- set argc [lindex $item 1]
- }
-
- if {$name == $option} {
- set result [list [list $name $argc]]
- break
- } elseif {[string first $option $name] == 0} {
- lappend result [list $name $argc]
- }
- }
-
- return $result
-}
-
-# Parse global options
-#
-# Note that this is called several times:
-# (1) Initially, to parse options that will be constant across all commands
-# (options that come prior to any command, frozen into global_options_base)
-# (2) Following each command (to parse options that will be unique to that command
-# (the global_options array is reset to global_options_base prior to each command)
-#
-proc parse_options { action ui_options_name global_options_name } {
- upvar $ui_options_name ui_options
- upvar $global_options_name global_options
- global cmdname cmd_opts_array
-
- while {[moreargs]} {
- set arg [lookahead]
-
- if {[string index $arg 0] ne "-"} {
- break
- } elseif {[string index $arg 1] eq "-"} {
- # Process long arguments
- switch -- $arg {
- -- { # This is the options terminator; do no further option processing
- advance; break
- }
- default {
- set key [string range $arg 2 end]
- set kopts [cmd_option_matches $action $key]
- if {[llength $kopts] == 0} {
- return -code error "${action} does not accept --${key}"
- } elseif {[llength $kopts] > 1} {
- set errlst {}
- foreach e $kopts {
- lappend errlst "--[lindex $e 0]"
- }
- return -code error "\"port ${action} --${key}\" is ambiguous: \n port ${action} [join $errlst "\n port ${action} "]"
- }
- set key [lindex $kopts 0 0]
- set kargc [lindex $kopts 0 1]
- if {$kargc == 0} {
- set global_options(ports_${action}_${key}) yes
- } else {
- set args {}
- while {[moreargs] && $kargc > 0} {
- advance
- lappend args [lookahead]
- set kargc [expr {$kargc - 1}]
- }
- if {$kargc > 0} {
- return -code error "--${key} expects [expr {$kargc + [llength $args]}] parameters!"
- }
- set global_options(ports_${action}_${key}) $args
- }
- }
- }
- } else {
- # Process short arg(s)
- set opts [string range $arg 1 end]
- foreach c [split $opts {}] {
- switch -- $c {
- v {
- set ui_options(ports_verbose) yes
- }
- d {
- set ui_options(ports_debug) yes
- # debug implies verbose
- set ui_options(ports_verbose) yes
- }
- q {
- set ui_options(ports_quiet) yes
- }
- p {
- # Ignore errors while processing within a command
- set ui_options(ports_processall) yes
- }
- f {
- set global_options(ports_force) yes
- }
- o {
- set global_options(ports_ignore_different) yes
- }
- n {
- set global_options(ports_nodeps) yes
- }
- u {
- set global_options(port_uninstall_old) yes
- }
- R {
- set global_options(ports_do_dependents) yes
- }
- s {
- set global_options(ports_source_only) yes
- }
- b {
- set global_options(ports_binary_only) yes
- }
- c {
- set global_options(ports_autoclean) yes
- }
- k {
- set global_options(ports_autoclean) no
- }
- t {
- set global_options(ports_trace) yes
- }
- y {
- set global_options(ports_dryrun) yes
- }
- F {
- # Name a command file to process
- advance
- if {[moreargs]} {
- lappend ui_options(ports_commandfiles) [lookahead]
- }
- }
- D {
- advance
- if {[moreargs]} {
- cd [lookahead]
- }
- break
- }
- default {
- print_usage; exit 1
- }
- }
- }
- }
-
- advance
- }
-}
-
-# acquire exclusive registry lock for actions that need it
-# returns 1 if locked, 0 otherwise
-proc lock_reg_if_needed {action} {
- switch -- $action {
- activate -
- deactivate -
- setrequested -
- unsetrequested -
- upgrade -
- uninstall -
- install {
- registry::exclusive_lock
- return 1
- }
- }
- return 0
-}
-
-proc process_cmd { argv } {
- global cmd_argc cmd_argv cmd_argn \
- global_options global_options_base private_options ui_options \
- current_portdir
- set cmd_argv $argv
- set cmd_argc [llength $argv]
- set cmd_argn 0
-
- set action_status 0
-
- # Process an action if there is one
- while {($action_status == 0 || [macports::ui_isset ports_processall]) && [moreargs]} {
- set action [lookahead]
- advance
-
- # Handle command separator
- if { $action == ";" } {
- continue
- }
-
- # Handle a comment
- if { [string index $action 0] == "#" } {
- while { [moreargs] } { advance }
- break
- }
-
- set locked [lock_reg_if_needed $action]
- # Always start out processing an action in current_portdir
- cd $current_portdir
-
- # Reset global_options from base before each action, as we munge it just below...
- array unset global_options
- array set global_options $global_options_base
-
- # Find an action to execute
- set actions [find_action $action]
- if {[llength $actions] == 1} {
- set action [lindex $actions 0]
- set action_proc [get_action_proc $action]
- } else {
- if {[llength $actions] > 1} {
- ui_error "\"port ${action}\" is ambiguous: \n port [join $actions "\n port "]"
- } else {
- ui_error "Unrecognized action \"port $action\""
- }
- set action_status 1
- break
- }
-
- # Parse options that will be unique to this action
- # (to avoid abiguity with -variants and a default port, either -- must be
- # used to terminate option processing, or the pseudo-port current must be specified).
- if {[catch {parse_options $action ui_options global_options} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- ui_error $result
- set action_status 1
- break
- }
-
- # What kind of arguments does the command expect?
- set expand [action_needs_portlist $action]
-
- # Parse action arguments, setting a special flag if there were none
- # We otherwise can't tell the difference between arguments that evaluate
- # to the empty set, and the empty set itself.
- set portlist {}
- switch -- [lookahead] {
- ; -
- _EOF_ {
- set private_options(ports_no_args) yes
- }
- default {
- if {[ACTION_ARGS_NONE] == $expand} {
- ui_error "$action does not accept string arguments"
- set action_status 1
- break
- } elseif {[ACTION_ARGS_STRINGS] == $expand} {
- while { [moreargs] && ![match ";"] } {
- lappend portlist [lookahead]
- advance
- }
- } elseif {[ACTION_ARGS_PORTS] == $expand} {
- # Parse port specifications into portlist
- if {![portExpr portlist]} {
- ui_error "Improper expression syntax while processing parameters"
- set action_status 1
- break
- }
- }
- }
- }
-
- # execute the action
- set action_status [$action_proc $action $portlist [array get global_options]]
-
- # unlock if needed
- if {$locked} {
- registry::exclusive_unlock
- }
-
- # Print notifications of just-activated ports.
- portclient::notifications::display
-
- # semaphore to exit
- if {$action_status == -999} break
- }
-
- return $action_status
-}
-
-
-proc complete_portname { text state } {
- global complete_choices complete_position
-
- if {$state == 0} {
- set complete_position 0
- set complete_choices {}
-
- # Build a list of ports with text as their prefix
- if {[catch {set res [mportsearch "${text}*" false glob]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "search for portname $pattern failed: $result"
- }
- foreach {name info} $res {
- lappend complete_choices $name
- }
- }
-
- set word [lindex $complete_choices $complete_position]
- incr complete_position
-
- return $word
-}
-
-
-# return text action beginning with $text
-proc complete_action { text state } {
- global action_array complete_choices complete_position
-
- if {$state == 0} {
- set complete_position 0
- set complete_choices [array names action_array "[string tolower $text]*"]
- }
-
- set word [lindex $complete_choices $complete_position]
- incr complete_position
-
- return $word
-}
-
-# return all actions beginning with $text
-proc guess_action { text } {
- global action_array
-
- return [array names action_array "[string tolower $text]*"]
-
- if { [llength $complete_choices ] == 1 } {
- return [lindex $complete_choices 0]
- }
-
- return {}
-}
-
-proc attempt_completion { text word start end } {
- # If the word starts with '~', or contains '.' or '/', then use the build-in
- # completion to complete the word
- if { [regexp {^~|[/.]} $word] } {
- return ""
- }
-
- # Decide how to do completion based on where we are in the string
- set prefix [string range $text 0 [expr {$start - 1}]]
-
- # If only whitespace characters preceed us, or if the
- # previous non-whitespace character was a ;, then we're
- # an action (the first word of a command)
- if { [regexp {(^\s*$)|(;\s*$)} $prefix] } {
- return complete_action
- }
-
- # Otherwise, do completion on portname
- return complete_portname
-}
-
-
-proc get_next_cmdline { in out use_readline prompt linename } {
- upvar $linename line
-
- set line ""
- while { $line eq "" } {
-
- if {$use_readline} {
- set len [readline read -attempted_completion attempt_completion line $prompt]
- } else {
- puts -nonewline $out $prompt
- flush $out
- set len [gets $in line]
- }
-
- if { $len < 0 } {
- return -1
- }
-
- set line [string trim $line]
-
- if { $use_readline && $line ne "" } {
- rl_history add $line
- }
- }
-
- return [llength $line]
-}
-
-
-proc process_command_file { in } {
- global current_portdir
-
- # Initialize readline
- set isstdin [string match $in "stdin"]
- set name "port"
- set use_readline [expr {$isstdin && [readline init $name]}]
- set history_file [file normalize "${macports::macports_user_dir}/history"]
-
- # Read readline history
- if {$use_readline && [file isdirectory $macports::macports_user_dir]} {
- rl_history read $history_file
- rl_history stifle 100
- }
-
- # Be noisy, if appropriate
- set noisy [expr $isstdin && ![macports::ui_isset ports_quiet]]
- if { $noisy } {
- puts "MacPorts [macports::version]"
- puts "Entering interactive mode... (\"help\" for help, \"quit\" to quit)"
- }
-
- # Main command loop
- set exit_status 0
- while { $exit_status == 0 || $isstdin || [macports::ui_isset ports_processall] } {
-
- # Calculate our prompt
- if { $noisy } {
- set shortdir [eval file join [lrange [file split $current_portdir] end-1 end]]
- set prompt "\[$shortdir\] > "
- } else {
- set prompt ""
- }
-
- # Get a command line
- if { [get_next_cmdline $in stdout $use_readline $prompt line] <= 0 } {
- puts ""
- break
- }
-
- # Process the command
- set exit_status [process_cmd $line]
-
- # Check for semaphore to exit
- if {$exit_status == -999} {
- set exit_status 0
- break
- }
- }
-
- # Create macports user directory if it does not exist yet
- if {$use_readline && ![file isdirectory $macports::macports_user_dir]} {
- file mkdir $macports::macports_user_dir
- }
- # Save readine history
- if {$use_readline && [file isdirectory $macports::macports_user_dir]} {
- rl_history write $history_file
- }
-
- # Say goodbye
- if { $noisy } {
- puts "Goodbye"
- }
-
- return $exit_status
-}
-
-
-proc process_command_files { filelist } {
- set exit_status 0
-
- # For each file in the command list, process commands
- # in the file
- foreach file $filelist {
- if {$file eq "-"} {
- set in stdin
- } else {
- if {[catch {set in [open $file]} result]} {
- fatal "Failed to open command file; $result"
- }
- }
-
- set exit_status [process_command_file $in]
-
- if {$in ne "stdin"} {
- close $in
- }
-
- # Exit on first failure unless -p was given
- if {$exit_status != 0 && ![macports::ui_isset ports_processall]} {
- return $exit_status
- }
- }
-
- return $exit_status
-}
-
-namespace eval portclient::progress {
- ##
- # Maximum width of the progress bar or indicator when displaying it.
- variable maxWidth 50
-
- ##
- # The start time of the last progress callback as returned by [clock time].
- # Since only one progress indicator is active at a time, this variable is
- # shared between the different variants of progress functions.
- variable startTime
-
- ##
- # Delay in milliseconds after the start of the operation before deciding
- # that showing a progress bar makes sense.
- variable showTimeThreshold 500
-
- ##
- # Percentage value between 0 and 1 that must not have been reached yet when
- # $showTimeThreshold has passed for a progress bar to be shown. If the
- # operation has proceeded above e.g. 75% after 500ms we won't bother
- # displaying a progress indicator anymore -- the operation will be finished
- # in well below a second anyway.
- variable showPercentageThreshold 0.75
-
- ##
- # Boolean indication whether the progress indicator should be shown or is
- # still hidden because the current operation didn't need enough time for
- # a progress indicator to make sense, yet.
- variable show no
-
- ##
- # Initialize the progress bar display delay; call this from the start
- # action of the progress functions.
- proc initDelay {} {
- variable show
- variable startTime
-
- set startTime [clock milliseconds]
- set show no
- }
-
- ##
- # Determine whether a progress bar should be shown for the current
- # operation in its current state. You must have called initDelay for the
- # current operation before calling this method.
- #
- # @param cur
- # Current progress in abstract units.
- # @param total
- # Total number of abstract units to be processed, if known. Pass
- # 0 if unknown.
- # @return
- # "yes", if the progress indicator should be shown, "no" otherwise.
- proc showProgress {cur total} {
- variable show
- variable startTime
- variable showTimeThreshold
- variable showPercentageThreshold
-
- if {$show eq "yes"} {
- return yes
- } else {
- if {[expr {[clock milliseconds] - $startTime}] > $showTimeThreshold &&
- ($total == 0 || [expr {double($cur) / double($total)}] < $showPercentageThreshold)} {
- set show yes
- }
- return $show
- }
- }
-
- ##
- # Progress callback for generic operations executed by macports 1.0.
- #
- # @param action
- # One of "start", "update", "intermission" or "finish", where start
- # will be called before any number of update calls, interrupted by
- # any number of intermission calls (called because other output is
- # being produced), followed by one call to finish.
- # @param args
- # A list of variadic args that differ for each action. For "start",
- # "intermission" and "finish", the args are empty and unused. For
- # "update", args contains $cur and $total, where $cur is the current
- # number of units processed and $total is the total number of units
- # to be processed. If the total is not known, it is 0.
- proc generic {action args} {
- global env
- variable maxWidth
-
- switch -nocase -- $action {
- start {
- initDelay
- }
- update {
- # the for loop is a simple hack because Tcl 8.4 doesn't have
- # lassign
- foreach {now total} $args {
- if {[showProgress $now $total] eq "yes"} {
- set barPrefix " "
- set barPrefixLen [string length $barPrefix]
- if {$total != 0} {
- progressbar $now $total [expr {min($maxWidth, $env(COLUMNS) - $barPrefixLen)}] $barPrefix
- } else {
- unprogressbar [expr {min($maxWidth, $env(COLUMNS) - $barPrefixLen)}] $barPrefix
- }
- }
- }
- }
- intermission -
- finish {
- # erase to start of line
- ::term::ansi::send::esol
- # return cursor to start of line
- puts -nonewline "\r"
- flush stdout
- }
- }
-
- return 0
- }
-
- ##
- # Progress callback for downloads executed by macports 1.0.
- #
- # This is essentially a cURL progress callback.
- #
- # @param action
- # One of "start", "update" or "finish", where start will be called
- # before any number of update calls, followed by one call to finish.
- # @param args
- # A list of variadic args that differ for each action. For "start",
- # contains a single argument "ul" or "dl" indicating whether this is
- # an up- or download. For "update", contains the arguments
- # ("ul"|"dl") $total $now $speed where ul/dl are as for start, and
- # total, now and speed are doubles indicating the total transfer
- # size, currently transferred amount and average speed per second in
- # bytes. Unused for "finish".
- proc download {action args} {
- global env
- variable maxWidth
-
- switch -nocase -- $action {
- start {
- initDelay
- }
- update {
- # the for loop is a simple hack because Tcl 8.4 doesn't have
- # lassign
- foreach {type total now speed} $args {
- if {[showProgress $now $total] eq "yes"} {
- set barPrefix " "
- set barPrefixLen [string length $barPrefix]
- if {$total != 0} {
- set barSuffix [format " speed: %-13s" "[bytesize $speed {} "%.1f"]/s"]
- set barSuffixLen [string length $barSuffix]
-
- set barLen [expr {min($maxWidth, $env(COLUMNS) - $barPrefixLen - $barSuffixLen)}]
- progressbar $now $total $barLen $barPrefix $barSuffix
- } else {
- set barSuffix [format " %-10s speed: %-13s" [bytesize $now {} "%6.1f"] "[bytesize $speed {} "%.1f"]/s"]
- set barSuffixLen [string length $barSuffix]
-
- set barLen [expr {min($maxWidth, $env(COLUMNS) - $barPrefixLen - $barSuffixLen)}]
- unprogressbar $barLen $barPrefix $barSuffix
- }
- }
- }
- }
- finish {
- # erase to start of line
- ::term::ansi::send::esol
- # return cursor to start of line
- puts -nonewline "\r"
- flush stdout
- }
- }
-
- return 0
- }
-
- ##
- # Draw a progress bar using unicode block drawing characters
- #
- # @param current
- # The current progress value.
- # @param total
- # The progress value representing 100%.
- # @param width
- # The width in characters of the progress bar. This includes percentage
- # output, which takes up 8 characters.
- # @param prefix
- # Prefix to be printed in front of the progress bar.
- # @param suffix
- # Suffix to be printed after the progress bar.
- proc progressbar {current total width {prefix ""} {suffix ""}} {
- # Subtract the width of the percentage output, also subtract the two
- # characters [ and ] bounding the progress bar.
- set percentageWidth 8
- set barWidth [expr {entier($width) - $percentageWidth - 2}]
-
- # Map the range (0, $total) to (0, 4 * $width) where $width is the maximum
- # numebr of characters to be printed for the progress bar. Multiply the
- # upper bound with 8 because we have 8 sub-states per character.
- set barProgress [expr {entier(round(($current * $barWidth * 8) / $total))}]
-
- set barInteger [expr {$barProgress / 8}]
- #set barRemainder [expr {$barProgress % 8}]
-
- # Finally, also provide a percentage value to print behind the progress bar
- set percentage [expr {double($current) * 100 / double($total)}]
-
- # clear the current line, enable reverse video
- set progressbar "\033\[7m"
- for {set i 0} {$i < $barInteger} {incr i} {
- # U+2588 FULL BLOCK doesn't match the other blocks in some fonts :/
- # Two half blocks work better in some fonts, but not in others (because
- # they leave ugly spaces). So, one or the other choice isn't better or
- # worse and even just using full blocks looks ugly in a few fonts.
-
- # Use pure ASCII until somebody fixes most of the default terminal fonts :/
- append progressbar " "
- }
- # back to normal output
- append progressbar "\033\[0m"
-
- #switch $barRemainder {
- # 0 {
- # if {$barInteger < $barWidth} {
- # append progressbar " "
- # }
- # }
- # 1 {
- # # U+258F LEFT ONE EIGHTH BLOCK
- # append progressbar "\u258f"
- # }
- # 2 {
- # # U+258E LEFT ONE QUARTER BLOCK
- # append progressbar "\u258e"
- # }
- # 3 {
- # # U+258D LEFT THREE EIGHTHS BLOCK
- # append progressbar "\u258d"
- # }
- # 3 {
- # # U+258D LEFT THREE EIGHTHS BLOCK
- # append progressbar "\u258d"
- # }
- # 4 {
- # # U+258C LEFT HALF BLOCK
- # append progressbar "\u258c"
- # }
- # 5 {
- # # U+258B LEFT FIVE EIGHTHS BLOCK
- # append progressbar "\u258b"
- # }
- # 6 {
- # # U+258A LEFT THREE QUARTERS BLOCK
- # append progressbar "\u258a"
- # }
- # 7 {
- # # U+2589 LEFT SEVEN EIGHTHS BLOCK
- # append progressbar "\u2589"
- # }
- #}
-
- # Fill the progress bar with spaces
- for {set i $barInteger} {$i < $barWidth} {incr i} {
- append progressbar " "
- }
-
- # Format the percentage using the space that has been reserved for it
- set percentagesuffix [format " %[expr {$percentageWidth - 3}].1f %%" $percentage]
-
- puts -nonewline "\r${prefix}\[${progressbar}\]${percentagesuffix}${suffix}"
- flush stdout
- }
-
-
- ##
- # Internal state of the progress indicator; unless you're hacking the
- # unprogressbar code you should never touch this.
- variable unprogressState 0
-
- ##
- # Draw a progress indicator
- #
- # @param width
- # The width in characters of the progress indicator.
- # @param prefix
- # Prefix to be printed in front of the progress indicator.
- # @param suffix
- # Suffix to be printed after the progress indicator.
- proc unprogressbar {width {prefix ""} {suffix ""}} {
- variable unprogressState
-
- # Subtract the two characters [ and ] bounding the progress indicator
- # from the width.
- set barWidth [expr {int($width) - 2}]
-
- # Number of states of the progress bar, or rather: the number of
- # characters before the sequence repeats.
- set numStates 4
-
- set unprogressState [expr {($unprogressState + 1) % $numStates}]
-
- set progressbar ""
- for {set i 0} {$i < $barWidth} {incr i} {
- if {[expr {$i % $numStates}] == $unprogressState} {
- # U+2022 BULLET
- append progressbar "\u2022"
- } else {
- append progressbar " "
- }
- }
-
- puts -nonewline "\r${prefix}\[${progressbar}\]${suffix}"
- flush stdout
- }
-}
-
-namespace eval portclient::notifications {
- ##
- # Ports whose notifications to display; these were either installed
- # or requested to be installed.
- variable notificationsToPrint
- array set notificationsToPrint {}
-
- ##
- # Add a port to the list for printing notifications.
- #
- # @param name
- # The name of the port.
- # @param note
- # A list of notes to be stored for the given port.
- proc append {name notes} {
- variable notificationsToPrint
-
- set notificationsToPrint($name) $notes
- }
-
- ##
- # Print port notifications.
- #
- proc display {} {
- global env
- variable notificationsToPrint
-
- # Display notes at the end of the activation phase.
- if {[array size notificationsToPrint] > 0} {
- ui_notice "---> Some of the ports you installed have notes:"
- foreach {name notes} [array get notificationsToPrint] {
- ui_notice " $name has the following notes:"
-
- # If env(COLUMNS) exists, limit each line's width to this width.
- if {[info exists env(COLUMNS)]} {
- set maxlen $env(COLUMNS)
-
- foreach note $notes {
- foreach line [split $note "\n"] {
- set joiner ""
- set lines ""
- set newline " "
-
- foreach word [split $line " "] {
- if {[string length $newline] + [string length $word] >= $maxlen} {
- lappend lines $newline
- set newline " "
- set joiner ""
- }
- ::append newline $joiner $word
- set joiner " "
- }
- if {$newline ne {}} {
- lappend lines $newline
- }
- ui_notice [join $lines "\n"]
- }
- }
- } else {
- foreach note $notes {
- ui_notice $note
- }
- }
- }
- }
- }
-}
-
-
-##########################################
-# Main
-##########################################
-
-# Global arrays passed to the macports1.0 layer
-array set ui_options {}
-array set global_options {}
-array set global_variations {}
-
-# Global options private to this script
-array set private_options {}
-
-# Make sure we get the size of the terminal
-# We do this here to save it in the boot_env, in case we determined it manually
-term_init_size
-
-global env boot_env argv0 cmdname argc argv cmd_argc cmd_argv cmd_argn \
- current_portdir global_options_base exit_status
-
-# Save off a copy of the environment before mportinit monkeys with it
-array set boot_env [array get env]
-
-set cmdname [file tail $argv0]
-
-# Setp cmd_argv to match argv
-set cmd_argv $argv
-set cmd_argc $argc
-set cmd_argn 0
-
-# make sure we're using a sane umask
-umask 022
-
-# If we've been invoked as portf, then the first argument is assumed
-# to be the name of a command file (i.e., there is an implicit -F
-# before any arguments).
-if {[moreargs] && $cmdname eq "portf"} {
- lappend ui_options(ports_commandfiles) [lookahead]
- advance
-}
-
-# Parse global options that will affect all subsequent commands
-if {[catch {parse_options "global" ui_options global_options} result]} {
- puts "Error: $result"
- print_usage
- exit 1
-}
-
-if {[isatty stdout]
- && $portclient::progress::hasTermAnsiSend eq "yes"
- && (![info exists ui_options(ports_quiet)] || $ui_options(ports_quiet) ne "yes")} {
- set ui_options(progress_download) portclient::progress::download
- set ui_options(progress_generic) portclient::progress::generic
-}
-
-set ui_options(notifications_append) portclient::notifications::append
-
-# Get arguments remaining after option processing
-set remaining_args [lrange $cmd_argv $cmd_argn end]
-
-# If we have no arguments remaining after option processing then force
-# interactive mode
-if { [llength $remaining_args] == 0 && ![info exists ui_options(ports_commandfiles)] } {
- lappend ui_options(ports_commandfiles) -
-} elseif {[lookahead] eq "selfupdate" || [lookahead] eq "sync"} {
- # tell mportinit not to tell the user they should selfupdate
- set ui_options(ports_no_old_index_warning) 1
-}
-
-# Initialize mport
-# This must be done following parse of global options, as some options are
-# evaluated by mportinit.
-if {[catch {mportinit ui_options global_options global_variations} result]} {
- global errorInfo
- puts "$errorInfo"
- fatal "Failed to initialize MacPorts, $result"
-}
-
-# Set up some global state for our code
-set current_portdir [pwd]
-
-# Freeze global_options into global_options_base; global_options
-# will be reset to global_options_base prior to processing each command.
-set global_options_base [array get global_options]
-
-# First process any remaining args as action(s)
-set exit_status 0
-if { [llength $remaining_args] > 0 } {
-
- # If there are remaining arguments, process those as a command
- set exit_status [process_cmd $remaining_args]
-}
-
-# Process any prescribed command files, including standard input
-if { ($exit_status == 0 || [macports::ui_isset ports_processall]) && [info exists ui_options(ports_commandfiles)] } {
- set exit_status [process_command_files $ui_options(ports_commandfiles)]
-}
-if {$exit_status == -999} {
- set exit_status 0
-}
-
-# shut down macports1.0
-mportshutdown
-
-# Return with exit_status
-exit $exit_status
Deleted: branches/gsoc14-cleanup/src/port/port.tcl.orig
===================================================================
--- branches/gsoc14-cleanup/src/port/port.tcl.orig 2014-08-13 22:14:51 UTC (rev 123747)
+++ branches/gsoc14-cleanup/src/port/port.tcl.orig 2014-08-13 22:14:53 UTC (rev 123748)
@@ -1,5361 +0,0 @@
-# -*- coding: utf-8; mode: tcl; tab-width: 4; indent-tabs-mode: nil; c-basic-offset: 4 -*- vim:fenc=utf-8:filetype=tcl:et:sw=4:ts=4:sts=4
-# $Id: port.tcl 119177 2014-04-18 22:35:29Z cal at macports.org $
-#
-# Copyright (c) 2004-2014 The MacPorts Project
-# Copyright (c) 2004 Robert Shaw <rshaw at opendarwin.org>
-# Copyright (c) 2002-2003 Apple 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 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.
-
-# Create a namespace for some local variables
-namespace eval portclient::progress {
- ##
- # Indicate whether the term::ansi::send tcllib package is available and was
- # imported. "yes", if the package is available, "no" otherwise.
- variable hasTermAnsiSend no
-}
-
-if {![catch {package require term::ansi::send}]} {
- set portclient::progress::hasTermAnsiSend yes
-}
-
-package require macports
-package require Pextlib 1.0
-
-# Standard procedures
-proc print_usage {{verbose 1}} {
- global cmdname
- set syntax {
- [-bcdfknopqRstuvy] [-D portdir] [-F cmdfile] action [privopts] [actionflags]
- [[portname|pseudo-portname|port-url] [@version] [+-variant]... [option=value]...]...
- }
-
- if {$verbose} {
- puts stderr "Usage: $cmdname$syntax"
- puts stderr "\"$cmdname help\" or \"man 1 port\" for more information."
- } else {
- puts stderr "$cmdname$syntax"
- }
-}
-
-proc print_help {args} {
- global action_array
-
- print_usage 0
-
- # Generate and format the command list from the action_array
- set cmds ""
- set lineLen 0
- foreach cmd [lsort [array names action_array]] {
- if {$lineLen > 65} {
- set cmds "$cmds,\n"
- set lineLen 0
- }
- if {$lineLen == 0} {
- set new "$cmd"
- } else {
- set new ", $cmd"
- }
- incr lineLen [string length $new]
- set cmds "$cmds$new"
- }
-
- set cmdText "Supported actions
-------------------
-$cmds
-"
-
- set text {
-Pseudo-portnames
-----------------
-Pseudo-portnames are words that may be used in place of a portname, and
-which expand to some set of ports. The common pseudo-portnames are:
-all, current, active, inactive, actinact, installed, uninstalled, outdated,
-obsolete, requested, unrequested and leaves.
-These pseudo-portnames expand to the set of ports named.
-
-Pseudo-portnames starting with variants:, variant:, description:, depends:,
-depends_lib:, depends_run:, depends_build:, depends_fetch:, depends_extract:,
-portdir:, homepage:, epoch:, platforms:, platform:, name:, long_description:,
-maintainers:, maintainer:, categories:, category:, version:, revision:, and
-license: each select a set of ports based on a regex search of metadata
-about the ports. In all such cases, a standard regex pattern following
-the colon will be used to select the set of ports to which the
-pseudo-portname expands.
-
-Pseudo-portnames starting with depof:, rdepof:, dependentof:, and rdependentof:
-select ports that are direct or recursive dependencies or dependents of the
-following portname, respectively.
-
-Portnames that contain standard glob characters will be expanded to the
-set of ports matching the glob pattern.
-
-Port expressions
-----------------
-Portnames, port glob patterns, and pseudo-portnames may be logically
-combined using expressions consisting of and, or, not, !, (, and ).
-
-For more information
---------------------
-See man pages: port(1), macports.conf(5), portfile(7), portgroup(7),
-porthier(7), portstyle(7). Also, see http://www.macports.org.
- }
-
- puts "$cmdText$text"
-}
-
-
-# Produce error message and exit
-proc fatal s {
- global argv0
- ui_error "$argv0: $s"
- exit 1
-}
-
-##
-# Helper function to define constants
-#
-# Constants defined with const can simply be accessed in the same way as
-# calling a proc.
-#
-# Example:
-# const FOO 42
-# puts [FOO]
-#
-# @param name variable name
-# @param value constant variable value
-proc const {name args} {
- proc $name {} [list return [expr $args]]
-}
-
-# Format an integer representing bytes using given units
-proc bytesize {siz {unit {}} {format {%.3f}}} {
- if {$unit == {}} {
- if {$siz > 0x40000000} {
- set unit "GiB"
- } elseif {$siz > 0x100000} {
- set unit "MiB"
- } elseif {$siz > 0x400} {
- set unit "KiB"
- } else {
- set unit "B"
- }
- }
- switch -- $unit {
- KiB {
- set siz [expr {$siz / 1024.0}]
- }
- kB {
- set siz [expr {$siz / 1000.0}]
- }
- MiB {
- set siz [expr {$siz / 1048576.0}]
- }
- MB {
- set siz [expr {$siz / 1000000.0}]
- }
- GiB {
- set siz [expr {$siz / 1073741824.0}]
- }
- GB {
- set siz [expr {$siz / 1000000000.0}]
- }
- B { }
- default {
- ui_warn "Unknown file size unit '$unit' specified"
- set unit "B"
- }
- }
- if {[expr {round($siz)}] != $siz} {
- set siz [format $format $siz]
- }
- return "$siz $unit"
-}
-
-proc filesize {fil {unit {}}} {
- set siz {@}
- catch {
- set siz [bytesize [file size $fil] $unit]
- }
- return $siz
-}
-
-# Produce an error message, and exit, unless
-# we're handling errors in a soft fashion, in which
-# case we continue
-proc fatal_softcontinue s {
- if {[macports::global_option_isset ports_force]} {
- ui_error $s
- return -code continue
- } else {
- fatal $s
- }
-}
-
-
-# Produce an error message, and break, unless
-# we're handling errors in a soft fashion, in which
-# case we continue
-proc break_softcontinue { msg status name_status } {
- upvar $name_status status_var
- ui_error $msg
- if {[macports::ui_isset ports_processall]} {
- set status_var 0
- return -code continue
- } else {
- set status_var $status
- return -code break
- }
-}
-
-# show the URL for the ticket reporting instructions
-proc print_tickets_url {args} {
- if {${macports::prefix} ne "/usr/local" && ${macports::prefix} ne "/usr"} {
- ui_error "Follow http://guide.macports.org/#project.tickets to report a bug."
- }
-}
-
-# Form a composite version as is sometimes used for registry functions
-# This function sorts the variants and presents them in a canonical representation
-proc composite_version {version variations {emptyVersionOkay 0}} {
- # Form a composite version out of the version and variations
-
- # Select the variations into positive and negative
- set pos {}
- set neg {}
- foreach { key val } $variations {
- if {$val eq "+"} {
- lappend pos $key
- } elseif {$val eq "-"} {
- lappend neg $key
- }
- }
-
- # If there is no version, we have nothing to do
- set composite_version ""
- if {$version ne "" || $emptyVersionOkay} {
- set pos_str ""
- set neg_str ""
-
- if {[llength $pos]} {
- set pos_str "+[join [lsort -ascii $pos] "+"]"
- }
- if {[llength $neg]} {
- set neg_str "-[join [lsort -ascii $neg] "-"]"
- }
-
- set composite_version "$version$pos_str$neg_str"
- }
-
- return $composite_version
-}
-
-
-proc split_variants {variants} {
- set result {}
- set l [regexp -all -inline -- {([-+])([[:alpha:]_]+[\w\.]*)} $variants]
- foreach { match sign variant } $l {
- lappend result $variant $sign
- }
- return $result
-}
-
-
-##
-# Maps friendly field names to their real name
-# Names which do not need mapping are not changed.
-#
-# @param field friendly name
-# @return real name
-proc map_friendly_field_names { field } {
- switch -- $field {
- variant -
- platform -
- maintainer -
- subport {
- set field "${field}s"
- }
- category {
- set field "categories"
- }
- }
-
- return $field
-}
-
-
-proc registry_installed {portname {portversion ""}} {
- set ilist [registry::installed $portname $portversion]
- if { [llength $ilist] > 1 } {
- # set portname again since the one we were passed may not have had the correct case
- set portname [lindex $ilist 0 0]
- ui_notice "The following versions of $portname are currently installed:"
- foreach i [portlist_sortint $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 -code error "Registry error: Please specify the full version as recorded in the port registry."
- } else {
- return [lindex $ilist 0]
- }
-}
-
-
-proc entry_for_portlist {portentry} {
- global global_options global_variations
-
- # Each portlist entry currently has the following elements in it:
- # url if any
- # name
- # version (version_revision)
- # variants array (variant=>+-)
- # requested_variants array (variant=>+-)
- # options array (key=>value)
- # fullname (name/version_revision+-variants)
-
- array set port $portentry
- if {![info exists port(url)]} { set port(url) "" }
- if {![info exists port(name)]} { set port(name) "" }
- if {![info exists port(version)]} { set port(version) "" }
- if {![info exists port(variants)]} { set port(variants) "" }
- if {![info exists port(requested_variants)]} { set port(requested_variants) "" }
- if {![info exists port(options)]} { set port(options) [array get global_options] }
-
- # If neither portname nor url is specified, then default to the current port
- if { $port(url) eq "" && $port(name) eq "" } {
- set url file://.
- set portname [url_to_portname $url]
- set port(url) $url
- set port(name) $portname
- if {$portname eq ""} {
- ui_error "A default port name could not be supplied."
- }
- }
-
- # Form the fully discriminated portname: portname/version_revison+-variants
- set port(fullname) "$port(name)/[composite_version $port(version) $port(variants)]"
-
- return [array get port]
-}
-
-
-proc add_to_portlist {listname portentry} {
- upvar $listname portlist
-
- # Form portlist entry and add to portlist
- lappend portlist [entry_for_portlist $portentry]
-}
-
-
-proc add_ports_to_portlist {listname ports {overridelist ""}} {
- upvar $listname portlist
-
- array set overrides $overridelist
-
- # Add each entry to the named portlist, overriding any values
- # specified as overrides
- foreach portentry $ports {
- array set port $portentry
- if ([info exists overrides(version)]) { set port(version) $overrides(version) }
- if ([info exists overrides(variants)]) { set port(variants) $overrides(variants) }
- if ([info exists overrides(requested_variants)]) { set port(requested_variants) $overrides(requested_variants) }
- if ([info exists overrides(options)]) { set port(options) $overrides(options) }
- add_to_portlist portlist [array get port]
- }
-}
-
-
-proc url_to_portname { url {quiet 0} } {
- # Save directory and restore the directory, since mportopen changes it
- set savedir [pwd]
- set portname ""
- if {[catch {set ctx [mportopen $url]} result]} {
- if {!$quiet} {
- ui_msg "Can't map the URL '$url' to a port description file (\"${result}\")."
- ui_msg "Please verify that the directory and portfile syntax are correct."
- }
- } else {
- array set portinfo [mportinfo $ctx]
- set portname $portinfo(name)
- mportclose $ctx
- }
- cd $savedir
- return $portname
-}
-
-
-# Supply a default porturl/portname if the portlist is empty
-proc require_portlist { nameportlist {is_upgrade "no"} } {
- global private_options
- upvar $nameportlist portlist
-
- if {[llength $portlist] == 0 && (![info exists private_options(ports_no_args)] || $private_options(ports_no_args) eq "no")} {
- if {${is_upgrade} == "yes"} {
- # $> port upgrade outdated
- # Error: No ports matched the given expression
- # is not very user friendly - if we're in the special case of
- # "upgrade", let's print a message that's a little easier to
- # understand and less alarming.
- ui_msg "Nothing to upgrade."
- return 1
- }
- ui_error "No ports matched the given expression"
- return 1
- }
-
- if {[llength $portlist] == 0} {
- set portlist [get_current_port]
-
- if {[llength $portlist] == 0} {
- # there was no port in current directory
- return 1
- }
- }
-
- return 0
-}
-
-
-# Execute the enclosed block once for every element in the portlist
-# When the block is entered, the following variables will have been set:
-# portspec, porturl, portname, portversion, options, variations, requested_variations
-proc foreachport {portlist block} {
- set savedir [pwd]
- foreach portspec $portlist {
-
- # Set the variables for the block
- uplevel 1 "array unset portspec; array set portspec { $portspec }"
- uplevel 1 {
- set porturl $portspec(url)
- set portname $portspec(name)
- set portversion $portspec(version)
- array unset variations
- array set variations $portspec(variants)
- array unset requested_variations
- array set requested_variations $portspec(requested_variants)
- array unset options
- array set options $portspec(options)
- }
-
- # Invoke block
- uplevel 1 $block
-
- # Restore cwd after each port, since mportopen changes it, and otherwise relative
- # urls would break on subsequent passes
- if {[file exists $savedir]} {
- cd $savedir
- } else {
- cd ~
- }
- }
-}
-
-
-proc portlist_compare { a b } {
- array set a_ $a
- array set b_ $b
- set namecmp [string equal -nocase $a_(name) $b_(name)]
- if {$namecmp != 1} {
- if {$a_(name) eq [lindex [lsort -dictionary [list $a_(name) $b_(name)]] 0]} {
- return -1
- }
- return 1
- }
- set avr_ [split $a_(version) "_"]
- set bvr_ [split $b_(version) "_"]
- set versioncmp [vercmp [lindex $avr_ 0] [lindex $bvr_ 0]]
- if {$versioncmp != 0} {
- return $versioncmp
- }
- set ar_ [lindex $avr_ 1]
- set br_ [lindex $bvr_ 1]
- if {$ar_ < $br_} {
- return -1
- } elseif {$ar_ > $br_} {
- return 1
- } else {
- return 0
- }
-}
-
-# Sort two ports in NVR (name at version_revision) order
-proc portlist_sort { list } {
- return [lsort -command portlist_compare $list]
-}
-
-proc portlist_compareint { a b } {
- array set a_ [list "name" [lindex $a 0] "version" "[lindex $a 1]_[lindex $a 2]"]
- array set b_ [list "name" [lindex $b 0] "version" "[lindex $b 1]_[lindex $b 2]"]
- return [portlist_compare [array get a_] [array get b_]]
-}
-
-# Same as portlist_sort, but with numeric indexes {name version revision}
-proc portlist_sortint { list } {
- return [lsort -command portlist_compareint $list]
-}
-
-# sort portlist so dependents come before their dependencies
-proc portlist_sortdependents { portlist } {
- foreach p $portlist {
- array set pvals $p
- lappend entries($pvals(name)) $p
- if {![info exists dependents($pvals(name))]} {
- set dependents($pvals(name)) {}
- foreach result [registry::list_dependents $pvals(name)] {
- lappend dependents($pvals(name)) [lindex $result 2]
- }
- }
- array unset pvals
- }
- set ret {}
- foreach p $portlist {
- portlist_sortdependents_helper $p entries dependents seen ret
- }
- return $ret
-}
-
-proc portlist_sortdependents_helper {p up_entries up_dependents up_seen up_retlist} {
- upvar $up_seen seen
- if {![info exists seen($p)]} {
- set seen($p) 1
- upvar $up_entries entries $up_dependents dependents $up_retlist retlist
- array set pvals $p
- foreach dependent $dependents($pvals(name)) {
- if {[info exists entries($dependent)]} {
- foreach entry $entries($dependent) {
- portlist_sortdependents_helper $entry entries dependents seen retlist
- }
- }
- }
- lappend retlist $p
- }
-}
-
-proc regex_pat_sanitize { s } {
- set sanitized [regsub -all {[\\(){}+$.^]} $s {\\&}]
- return $sanitized
-}
-
-##
-# Makes sure we get the current terminal size
-proc term_init_size {} {
- global env
-
- if {![info exists env(COLUMNS)] || ![info exists env(LINES)]} {
- if {[isatty stdout]} {
- set size [term_get_size stdout]
-
- if {![info exists env(LINES)] && [lindex $size 0] > 0} {
- set env(LINES) [lindex $size 0]
- }
-
- if {![info exists env(COLUMNS)] && [lindex $size 1] > 0} {
- set env(COLUMNS) [lindex $size 1]
- }
- }
- }
-}
-
-##
-# Wraps a multi-line string at specified textwidth
-#
-# @see wrapline
-#
-# @param string input string
-# @param maxlen text width (0 defaults to current terminal width)
-# @param indent prepend to every line
-# @return wrapped string
-proc wrap {string maxlen {indent ""} {indentfirstline 1}} {
- global env
-
- if {$maxlen == 0} {
- if {![info exists env(COLUMNS)]} {
- # no width for wrapping
- return $string
- }
- set maxlen $env(COLUMNS)
- }
-
- set splitstring {}
- set indentline $indentfirstline
- foreach line [split $string "\n"] {
- lappend splitstring [wrapline $line $maxlen $indent $indentline]
- set indentline 1
- }
- return [join $splitstring "\n"]
-}
-
-##
-# Wraps a line at specified textwidth
-#
-# @see wrap
-#
-# @param line input line
-# @param maxlen text width (0 defaults to current terminal width)
-# @param indent prepend to every line
-# @return wrapped string
-proc wrapline {line maxlen {indent ""} {indentfirstline 1}} {
- global env
-
- if {$maxlen == 0} {
- if {![info exists env(COLUMNS)]} {
- # no width for wrapping
- return $string
- }
- set maxlen $env(COLUMNS)
- }
-
- set string [split $line " "]
- if {$indentfirstline == 0} {
- set newline ""
- set maxlen [expr {$maxlen - [string length $indent]}]
- } else {
- set newline $indent
- }
- append newline [lindex $string 0]
- set joiner " "
- set first 1
- foreach word [lrange $string 1 end] {
- if {[string length $newline]+[string length $word] >= $maxlen} {
- lappend lines $newline
- set newline $indent
- set joiner ""
- # If indentfirstline is set to 0, reset maxlen to its
- # original length after appending the first line to lines.
- if {$first == 1 && $indentfirstline == 0} {
- set maxlen [expr {$maxlen + [string length $indent]}]
- }
- set first 0
- }
- append newline $joiner $word
- set joiner " "
- }
- lappend lines $newline
- return [join $lines "\n"]
-}
-
-##
-# Wraps a line at a specified width with a label in front
-#
-# @see wrap
-#
-# @param label label for output
-# @param string input string
-# @param maxlen text width (0 defaults to current terminal width)
-# @return wrapped string
-proc wraplabel {label string maxlen {indent ""}} {
- append label ": [string repeat " " [expr {[string length $indent] - [string length "$label: "]}]]"
- return "$label[wrap $string $maxlen $indent 0]"
-}
-
-proc unobscure_maintainers { list } {
- set result {}
- foreach m $list {
- if {[string first "@" $m] < 0} {
- if {[string first ":" $m] >= 0} {
- set m [regsub -- "(.*):(.*)" $m "\\2@\\1"]
- } else {
- set m "$m at macports.org"
- }
- }
- lappend result $m
- }
- return $result
-}
-
-
-##########################################
-# Port selection
-##########################################
-proc unique_results_to_portlist {infos} {
- set result {}
- array unset unique
- foreach {name info} $infos {
- array unset portinfo
- array set portinfo $info
-
- set portentry [entry_for_portlist [list url $portinfo(porturl) name $name]]
-
- array unset entry
- array set entry $portentry
-
- if {[info exists unique($entry(fullname))]} continue
- set unique($entry(fullname)) 1
-
- lappend result $portentry
- }
- return $result
-}
-
-
-proc get_matching_ports {pattern {casesensitive no} {matchstyle glob} {field name}} {
- if {[catch {set res [mportsearch $pattern $casesensitive $matchstyle $field]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "search for portname $pattern failed: $result"
- }
- set results [unique_results_to_portlist $res]
-
- # Return the list of all ports, sorted
- return [portlist_sort $results]
-}
-
-
-proc get_all_ports {} {
- global all_ports_cache
-
- if {![info exists all_ports_cache]} {
- if {[catch {set res [mportlistall]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "listing all ports failed: $result"
- }
- set results [unique_results_to_portlist $res]
- set all_ports_cache [portlist_sort $results]
- }
- return $all_ports_cache
-}
-
-
-proc get_current_ports {} {
- # This is just a synonym for get_current_port that
- # works with the regex in element
- return [get_current_port]
-}
-
-
-proc get_current_port {} {
- set url file://.
- set portname [url_to_portname $url]
- if {$portname eq ""} {
- ui_msg "To use the current port, you must be in a port's directory."
- return [list]
- }
-
- set results {}
- add_to_portlist results [list url $url name $portname]
- return $results
-}
-
-
-proc get_installed_ports { {ignore_active yes} {active yes} } {
- set ilist {}
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "port installed failed: $result"
- }
- }
-
- set results {}
- foreach i $ilist {
- set iname [lindex $i 0]
- set iversion [lindex $i 1]
- set irevision [lindex $i 2]
- set ivariants [split_variants [lindex $i 3]]
- set iactive [lindex $i 4]
-
- if { ${ignore_active} == "yes" || (${active} == "yes") == (${iactive} != 0) } {
- add_to_portlist results [list name $iname version "${iversion}_${irevision}" variants $ivariants]
- }
- }
-
- # Return the list of ports, sorted
- return [portlist_sort $results]
-}
-
-
-proc get_uninstalled_ports {} {
- # Return all - installed
- set all [get_all_ports]
- set installed [get_installed_ports]
- return [opComplement $all $installed]
-}
-
-
-proc get_active_ports {} {
- return [get_installed_ports no yes]
-}
-
-
-proc get_inactive_ports {} {
- return [get_installed_ports no no]
-}
-
-proc get_actinact_ports {} {
- set inactive_ports [get_inactive_ports]
- set active_ports [get_active_ports]
- set results {}
-
- foreach port $inactive_ports {
- array set portspec $port
- set portname $portspec(name)
- lappend inact($portname) $port
- }
-
- foreach port $active_ports {
- array set portspec $port
- set portname $portspec(name)
-
- if {[info exists inact($portname)]} {
- if {![info exists added_inact($portname)]} {
- foreach inact_spec $inact($portname) {
- lappend results $inact_spec
- }
- set added_inact($portname) 1
- }
- lappend results $port
- }
- }
- return $results
-}
-
-
-proc get_outdated_ports {} {
- # Get the list of installed ports
- set ilist {}
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "port installed failed: $result"
- }
- }
-
- # Now process the list, keeping only those ports that are outdated
- set results {}
- if { [llength $ilist] > 0 } {
- foreach i $ilist {
-
- # Get information about the installed port
- set portname [lindex $i 0]
- set installed_version [lindex $i 1]
- set installed_revision [lindex $i 2]
- set installed_compound "${installed_version}_${installed_revision}"
- set installed_variants [lindex $i 3]
-
- set is_active [lindex $i 4]
- if {$is_active == 0} continue
-
- set installed_epoch [lindex $i 5]
-
- # Get info about the port from the index
- if {[catch {set res [mportlookup $portname]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "lookup of portname $portname failed: $result"
- }
- if {[llength $res] < 2} {
- if {[macports::ui_isset ports_debug]} {
- puts stderr "$portname ($installed_compound is installed; the port was not found in the port index)"
- }
- continue
- }
- array unset portinfo
- array set portinfo [lindex $res 1]
-
- # Get information about latest available version and revision
- set latest_version $portinfo(version)
- set latest_revision 0
- if {[info exists portinfo(revision)] && $portinfo(revision) > 0} {
- set latest_revision $portinfo(revision)
- }
- set latest_compound "${latest_version}_${latest_revision}"
- set latest_epoch 0
- if {[info exists portinfo(epoch)]} {
- set latest_epoch $portinfo(epoch)
- }
-
- # Compare versions, first checking epoch, then version, then revision
- set comp_result 0
- if {$installed_version != $latest_version} {
- set comp_result [expr {$installed_epoch - $latest_epoch}]
- if { $comp_result == 0 } {
- set comp_result [vercmp $installed_version $latest_version]
- }
- }
- if { $comp_result == 0 } {
- set comp_result [expr {$installed_revision - $latest_revision}]
- }
- if {$comp_result == 0} {
- set regref [registry::open_entry $portname $installed_version $installed_revision $installed_variants $installed_epoch]
- set os_platform_installed [registry::property_retrieve $regref os_platform]
- set os_major_installed [registry::property_retrieve $regref os_major]
- if {$os_platform_installed ne "" && $os_platform_installed != 0
- && $os_major_installed ne "" && $os_major_installed != 0
- && ($os_platform_installed != ${macports::os_platform} || $os_major_installed != ${macports::os_major})} {
- set comp_result -1
- }
- }
-
- # Add outdated ports to our results list
- if { $comp_result < 0 } {
- add_to_portlist results [list name $portname version $installed_compound variants [split_variants $installed_variants]]
- }
- }
- }
-
- return [portlist_sort $results]
-}
-
-
-proc get_obsolete_ports {} {
- set ilist [get_installed_ports]
- set results {}
-
- foreach i $ilist {
- array set port $i
-
- if {[catch {mportlookup $port(name)} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
-
- if {[llength $result] < 2} {
- lappend results $i
- }
- }
-
- # Return the list of ports, already sorted
- return [portlist_sort $results]
-}
-
-# return ports that have registry property $propname set to $propval
-proc get_ports_with_prop {propname propval} {
- set ilist {}
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "port installed failed: $result"
- }
- }
-
- set results {}
- foreach i $ilist {
- set iname [lindex $i 0]
- set iversion [lindex $i 1]
- set irevision [lindex $i 2]
- set ivariants [lindex $i 3]
- set iepoch [lindex $i 5]
- set regref [registry::open_entry $iname $iversion $irevision $ivariants $iepoch]
- if {[registry::property_retrieve $regref $propname] == $propval} {
- add_to_portlist results [list name $iname version "${iversion}_${irevision}" variants [split_variants $ivariants]]
- }
- }
-
- # Return the list of ports, sorted
- return [portlist_sort $results]
-}
-
-proc get_requested_ports {} {
- return [get_ports_with_prop requested 1]
-}
-
-proc get_unrequested_ports {} {
- return [get_ports_with_prop requested 0]
-}
-
-proc get_leaves_ports {} {
- set ilist {}
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "port installed failed: $result"
- }
- }
- registry::open_dep_map
- set results {}
- foreach i $ilist {
- set iname [lindex $i 0]
- if {[registry::list_dependents $iname] eq ""} {
- add_to_portlist results [list name $iname version "[lindex $i 1]_[lindex $i 2]" variants [split_variants [lindex $i 3]]]
- }
- }
- return [portlist_sort [opIntersection $results [get_unrequested_ports]]]
-}
-
-proc get_dependent_ports {portname recursive} {
- registry::open_dep_map
- set deplist [registry::list_dependents $portname]
- # could return specific versions here using registry2.0 features
- set results {}
- foreach dep $deplist {
- add_to_portlist results [list name [lindex $dep 2]]
- }
-
- # actually do this iteratively to avoid hitting Tcl's recursion limit
- if {$recursive} {
- while 1 {
- set rportlist {}
- set newlist {}
- foreach dep $deplist {
- set depname [lindex $dep 2]
- if {![info exists seen($depname)]} {
- set seen($depname) 1
- set rdeplist [registry::list_dependents $depname]
- foreach rdep $rdeplist {
- lappend newlist $rdep
- add_to_portlist rportlist [list name [lindex $rdep 2]]
- }
- }
- }
- if {[llength $rportlist] > 0} {
- set results [opUnion $results $rportlist]
- set deplist $newlist
- } else {
- break
- }
- }
- }
-
- return [portlist_sort $results]
-}
-
-
-proc get_dep_ports {portname recursive} {
- global global_variations
-
- # look up portname
- if {[catch {mportlookup $portname} result]} {
- ui_debug "$::errorInfo"
- return -code error "lookup of portname $portname failed: $result"
- }
- if {[llength $result] < 2} {
- return -code error "Port $portname not found"
- }
- array unset portinfo
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
-
- # open portfile
- if {[catch {set mport [mportopen $porturl [list subport $portinfo(name)] [array get global_variations]]} result]} {
- ui_debug "$::errorInfo"
- return -code error "Unable to open port: $result"
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
-
- # gather its deps
- set results {}
- set deptypes {depends_fetch depends_extract depends_build depends_lib depends_run}
-
- set deplist {}
- foreach type $deptypes {
- if {[info exists portinfo($type)]} {
- foreach dep $portinfo($type) {
- add_to_portlist results [list name [lindex [split $dep :] end]]
- lappend deplist $dep
- }
- }
- }
-
- # actually do this iteratively to avoid hitting Tcl's recursion limit
- if {$recursive} {
- while 1 {
- set rportlist {}
- set newlist {}
- foreach dep $deplist {
- set depname [lindex [split $dep :] end]
- if {![info exists seen($depname)]} {
- set seen($depname) 1
-
- # look up the dep
- if {[catch {mportlookup $depname} result]} {
- ui_debug "$::errorInfo"
- return -code error "lookup of portname $depname failed: $result"
- }
- if {[llength $result] < 2} {
- ui_error "Port $depname not found"
- continue
- }
- array unset portinfo
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
-
- # open its portfile
- if {[catch {set mport [mportopen $porturl [list subport $portinfo(name)] [array get global_variations]]} result]} {
- ui_debug "$::errorInfo"
- ui_error "Unable to open port: $result"
- continue
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
-
- # collect its deps
- set rdeplist {}
- foreach type $deptypes {
- if {[info exists portinfo($type)]} {
- foreach rdep $portinfo($type) {
- add_to_portlist results [list name [lindex [split $rdep :] end]]
- lappend rdeplist $rdep
- }
- }
- }
-
- # add them to the lists
- foreach rdep $rdeplist {
- lappend newlist $rdep
- add_to_portlist rportlist [list name [lindex [split $rdep :] end]]
- }
- }
- }
- if {[llength $rportlist] > 0} {
- set results [opUnion $results $rportlist]
- set deplist $newlist
- } else {
- break
- }
- }
- }
-
- return [portlist_sort $results]
-}
-
-proc get_subports {portname} {
- global global_variations
-
- # look up portname
- if {[catch {mportlookup $portname} result]} {
- ui_debug "$::errorInfo"
- return -code error "lookup of portname $portname failed: $result"
- }
- if {[llength $result] < 2} {
- return -code error "Port $portname not found"
- }
- array unset portinfo
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
-
- # open portfile
- if {[catch {set mport [mportopen $porturl [list subport $portinfo(name)] [array get global_variations]]} result]} {
- ui_debug "$::errorInfo"
- return -code error "Unable to open port: $result"
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
-
- # gather its subports
- set results {}
-
- if {[info exists portinfo(subports)]} {
- foreach subport $portinfo(subports) {
- add_to_portlist results [list name $subport]
- }
- }
-
- return [portlist_sort $results]
-}
-
-
-##########################################
-# Port expressions
-##########################################
-proc portExpr { resname } {
- upvar $resname reslist
- set result [seqExpr reslist]
- return $result
-}
-
-
-proc seqExpr { resname } {
- upvar $resname reslist
-
- # Evaluate a sequence of expressions a b c...
- # These act the same as a or b or c
-
- set result 1
- while {$result} {
- switch -- [lookahead] {
- ; -
- ) -
- _EOF_ { break }
- }
-
- set blist {}
- set result [orExpr blist]
- if {$result} {
- # Calculate the union of result and b
- set reslist [opUnion $reslist $blist]
- }
- }
-
- return $result
-}
-
-
-proc orExpr { resname } {
- upvar $resname reslist
-
- set a [andExpr reslist]
- while ($a) {
- switch -- [lookahead] {
- or {
- advance
- set blist {}
- if {![andExpr blist]} {
- return 0
- }
-
- # Calculate a union b
- set reslist [opUnion $reslist $blist]
- }
- default {
- return $a
- }
- }
- }
-
- return $a
-}
-
-
-proc andExpr { resname } {
- upvar $resname reslist
-
- set a [unaryExpr reslist]
- while {$a} {
- switch -- [lookahead] {
- and {
- advance
-
- set blist {}
- set b [unaryExpr blist]
- if {!$b} {
- return 0
- }
-
- # Calculate a intersect b
- set reslist [opIntersection $reslist $blist]
- }
- default {
- return $a
- }
- }
- }
-
- return $a
-}
-
-
-proc unaryExpr { resname } {
- upvar $resname reslist
- set result 0
-
- switch -- [lookahead] {
- ! -
- not {
- advance
- set blist {}
- set result [unaryExpr blist]
- if {$result} {
- set all [get_all_ports]
- set reslist [opComplement $all $blist]
- }
- }
- default {
- set result [element reslist]
- }
- }
-
- return $result
-}
-
-
-proc element { resname } {
- upvar $resname reslist
- set el 0
-
- set url ""
- set name ""
- set version ""
- array unset requested_variants
- array unset options
-
- set token [lookahead]
- switch -regex -- $token {
- ^\\)$ -
- ^\; -
- ^_EOF_$ { # End of expression/cmd/file
- }
-
- ^\\($ { # Parenthesized Expression
- advance
- set el [portExpr reslist]
- if {!$el || ![match ")"]} {
- set el 0
- }
- }
-
- ^all(@.*)?$ -
- ^installed(@.*)?$ -
- ^uninstalled(@.*)?$ -
- ^active(@.*)?$ -
- ^inactive(@.*)?$ -
- ^actinact(@.*)?$ -
- ^leaves(@.*)?$ -
- ^outdated(@.*)?$ -
- ^obsolete(@.*)?$ -
- ^requested(@.*)?$ -
- ^unrequested(@.*)?$ -
- ^current(@.*)?$ {
- # A simple pseudo-port name
- advance
-
- # Break off the version component, if there is one
- regexp {^(\w+)(@.*)?} $token matchvar name remainder
-
- add_multiple_ports reslist [get_${name}_ports] $remainder
-
- set el 1
- }
-
- ^variants: -
- ^variant: -
- ^description: -
- ^portdir: -
- ^homepage: -
- ^epoch: -
- ^platforms: -
- ^platform: -
- ^name: -
- ^long_description: -
- ^maintainers: -
- ^maintainer: -
- ^categories: -
- ^category: -
- ^version: -
- ^depends_lib: -
- ^depends_build: -
- ^depends_run: -
- ^depends_extract: -
- ^depends_fetch: -
- ^replaced_by: -
- ^revision: -
- ^subport: -
- ^subports: -
- ^license: { # Handle special port selectors
- advance
-
- # Break up the token, because older Tcl switch doesn't support -matchvar
- regexp {^(\w+):(.*)} $token matchvar field pat
-
- # Remap friendly names to actual names
- set field [map_friendly_field_names $field]
-
- add_multiple_ports reslist [get_matching_ports $pat no regexp $field]
- set el 1
- }
-
- ^depends: { # A port selector shorthand for depends_{lib,build,run,fetch,extract}
- advance
-
- # Break up the token, because older Tcl switch doesn't support -matchvar
- regexp {^(\w+):(.*)} $token matchvar field pat
-
- add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_lib"]
- add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_build"]
- add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_run"]
- add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_extract"]
- add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_fetch"]
-
- set el 1
- }
-
- ^dependentof: -
- ^rdependentof: {
- advance
-
- # Break up the token, because older Tcl switch doesn't support -matchvar
- regexp {^(\w+):(.*)} $token matchvar selector portname
-
- set recursive [string equal $selector "rdependentof"]
- add_multiple_ports reslist [get_dependent_ports $portname $recursive]
-
- set el 1
- }
-
- ^depof: -
- ^rdepof: {
- advance
-
- # Break up the token, because older Tcl switch doesn't support -matchvar
- regexp {^(\w+):(.*)} $token matchvar selector portname
-
- set recursive [string equal $selector "rdepof"]
- add_multiple_ports reslist [get_dep_ports $portname $recursive]
-
- set el 1
- }
-
- ^subportof: {
- advance
-
- # Break up the token, because older Tcl switch doesn't support -matchvar
- regexp {^(\w+):(.*)} $token matchvar selector portname
-
- add_multiple_ports reslist [get_subports $portname]
-
- set el 1
- }
-
- [][?*] { # Handle portname glob patterns
- advance; add_multiple_ports reslist [get_matching_ports $token no glob]
- set el 1
- }
-
- ^\\w+:.+ { # Handle a url by trying to open it as a port and mapping the name
- advance
- set name [url_to_portname $token]
- if {$name ne ""} {
- parsePortSpec version requested_variants options
- add_to_portlist reslist [list url $token \
- name $name \
- version $version \
- requested_variants [array get requested_variants] \
- variants [array get requested_variants] \
- options [array get options]]
- set el 1
- } else {
- ui_error "Can't open URL '$token' as a port"
- set el 0
- }
- }
-
- default { # Treat anything else as a portspec (portname, version, variants, options
- # or some combination thereof).
- parseFullPortSpec url name version requested_variants options
- add_to_portlist reslist [list url $url \
- name $name \
- version $version \
- requested_variants [array get requested_variants] \
- variants [array get requested_variants] \
- options [array get options]]
- set el 1
- }
- }
-
- return $el
-}
-
-
-proc add_multiple_ports { resname ports {remainder ""} } {
- upvar $resname reslist
-
- set version ""
- array unset variants
- array unset options
- parsePortSpec version variants options $remainder
-
- array unset overrides
- if {$version ne ""} { set overrides(version) $version }
- if {[array size variants]} {
- # we always record the requested variants separately,
- # but requested ones always override existing ones
- set overrides(requested_variants) [array get variants]
- set overrides(variants) [array get variants]
- }
- if {[array size options]} { set overrides(options) [array get options] }
-
- add_ports_to_portlist reslist $ports [array get overrides]
-}
-
-
-proc unique_entries { entries } {
- # Form the list of all the unique elements in the list a,
- # considering only the port fullname, and taking the first
- # found element first
- set result {}
- array unset unique
- foreach item $entries {
- array set port $item
- if {[info exists unique($port(fullname))]} continue
- set unique($port(fullname)) 1
- lappend result $item
- }
- return $result
-}
-
-
-proc opUnion { a b } {
- # Return the unique elements in the combined two lists
- return [unique_entries [concat $a $b]]
-}
-
-
-proc opIntersection { a b } {
- set result {}
-
- # Rules we follow in performing the intersection of two port lists:
- #
- # a/, a/ ==> a/
- # a/, b/ ==>
- # a/, a/1.0 ==> a/1.0
- # a/1.0, a/ ==> a/1.0
- # a/1.0, a/2.0 ==>
- #
- # If there's an exact match, we take it.
- # If there's a match between simple and discriminated, we take the later.
-
- # First create a list of the fully discriminated names in b
- array unset bfull
- set i 0
- foreach bitem [unique_entries $b] {
- array set port $bitem
- set bfull($port(fullname)) $i
- incr i
- }
-
- # Walk through each item in a, matching against b
- foreach aitem [unique_entries $a] {
- array set port $aitem
-
- # Quote the fullname and portname to avoid special characters messing up the regexp
- set safefullname [regex_pat_sanitize $port(fullname)]
-
- set simpleform [expr { "$port(name)/" == $port(fullname) }]
- if {$simpleform} {
- set pat "^${safefullname}"
- } else {
- set safename [regex_pat_sanitize $port(name)]
- set pat "^${safefullname}$|^${safename}/$"
- }
-
- set matches [array names bfull -regexp $pat]
- foreach match $matches {
- if {$simpleform} {
- set i $bfull($match)
- lappend result [lindex $b $i]
- } else {
- lappend result $aitem
- }
- }
- }
-
- return $result
-}
-
-
-proc opComplement { a b } {
- set result {}
-
- # Return all elements of a not matching elements in b
-
- # First create a list of the fully discriminated names in b
- array unset bfull
- set i 0
- foreach bitem $b {
- array set port $bitem
- set bfull($port(fullname)) $i
- incr i
- }
-
- # Walk through each item in a, taking all those items that don't match b
- foreach aitem $a {
- array set port $aitem
-
- # Quote the fullname and portname to avoid special characters messing up the regexp
- set safefullname [regex_pat_sanitize $port(fullname)]
-
- set simpleform [expr { "$port(name)/" == $port(fullname) }]
- if {$simpleform} {
- set pat "^${safefullname}"
- } else {
- set safename [regex_pat_sanitize $port(name)]
- set pat "^${safefullname}$|^${safename}/$"
- }
-
- set matches [array names bfull -regexp $pat]
-
- # We copy this element to result only if it didn't match against b
- if {![llength $matches]} {
- lappend result $aitem
- }
- }
-
- return $result
-}
-
-
-proc parseFullPortSpec { urlname namename vername varname optname } {
- upvar $urlname porturl
- upvar $namename portname
- upvar $vername portversion
- upvar $varname portvariants
- upvar $optname portoptions
-
- set portname ""
- set portversion ""
- array unset portvariants
- array unset portoptions
-
- if { [moreargs] } {
- # Look first for a potential portname
- #
- # We need to allow a wide variety of tokens here, because of actions like "provides"
- # so we take a rather lenient view of what a "portname" is. We allow
- # anything that doesn't look like either a version, a variant, or an option
- set token [lookahead]
-
- set remainder ""
- if {|[[:alpha:]_]+[\w\.]*=)} $token match]} {
- advance
- regexp {^([^@]+)(@.*)?} $token match portname remainder
-
- # If the portname contains a /, then try to use it as a URL
- if {[string match "*/*" $portname]} {
- set url "file://$portname"
- set name [url_to_portname $url 1]
- if { $name ne "" } {
- # We mapped the url to valid port
- set porturl $url
- set portname $name
- # Continue to parse rest of portspec....
- } else {
- # We didn't map the url to a port; treat it
- # as a raw string for something like port contents
- # or cd
- set porturl ""
- # Since this isn't a port, we don't try to parse
- # any remaining portspec....
- return
- }
- }
- }
-
- # Now parse the rest of the spec
- parsePortSpec portversion portvariants portoptions $remainder
- }
-}
-
-# check if the install prefix is writable
-# should be called by actions that will modify it
-proc prefix_unwritable {} {
- global macports::portdbpath
- if {[file writable $portdbpath]} {
- return 0
- } else {
- ui_error "Insufficient privileges to write to MacPorts install prefix."
- return 1
- }
-}
-
-
-proc parsePortSpec { vername varname optname {remainder ""} } {
- upvar $vername portversion
- upvar $varname portvariants
- upvar $optname portoptions
-
- global global_options
-
- set portversion ""
- array unset portoptions
- array set portoptions [array get global_options]
- array unset portvariants
-
- # Parse port version/variants/options
- set opt $remainder
- set adv 0
- set consumed 0
- for {set firstTime 1} {$opt ne "" || [moreargs]} {set firstTime 0} {
-
- # Refresh opt as needed
- if {$opt eq ""} {
- if {$adv} advance
- set opt [lookahead]
- set adv 1
- set consumed 0
- }
-
- # Version must be first, if it's there at all
- if {$firstTime && [string match {@*} $opt]} {
- # Parse the version
-
- # Strip the @
- set opt [string range $opt 1 end]
-
- # Handle the version
- set sepPos [string first "/" $opt]
- if {$sepPos >= 0} {
- # Version terminated by "/" to disambiguate -variant from part of version
- set portversion [string range $opt 0 [expr {$sepPos - 1}]]
- set opt [string range $opt [expr {$sepPos + 1}] end]
- } else {
- # Version terminated by "+", or else is complete
- set sepPos [string first "+" $opt]
- if {$sepPos >= 0} {
- # Version terminated by "+"
- set portversion [string range $opt 0 [expr {$sepPos - 1}]]
- set opt [string range $opt $sepPos end]
- } else {
- # Unterminated version
- set portversion $opt
- set opt ""
- }
- }
- set consumed 1
- } else {
- # Parse all other options
-
- # Look first for a variable setting: VARNAME=VALUE
- if {[regexp {^([[:alpha:]_]+[\w\.]*)=(.*)} $opt match key val] == 1} {
- # It's a variable setting
- set portoptions($key) "\"$val\""
- set opt ""
- set consumed 1
- } elseif {[regexp {^([-+])([[:alpha:]_]+[\w\.]*)} $opt match sign variant] == 1} {
- # It's a variant
- set portvariants($variant) $sign
- set opt [string range $opt [expr {[string length $variant] + 1}] end]
- set consumed 1
- } else {
- # Not an option we recognize, so break from port option processing
- if { $consumed && $adv } advance
- break
- }
- }
- }
-}
-
-
-##########################################
-# Action Handlers
-##########################################
-
-proc action_get_usage { action } {
- global action_array cmd_opts_array
-
- if {[info exists action_array($action)]} {
- set cmds ""
- if {[info exists cmd_opts_array($action)]} {
- foreach opt $cmd_opts_array($action) {
- if {[llength $opt] == 1} {
- set name $opt
- set optc 0
- } else {
- set name [lindex $opt 0]
- set optc [lindex $opt 1]
- }
-
- append cmds " --$name"
-
- for {set i 1} {$i <= $optc} {incr i} {
- append cmds " <arg$i>"
- }
- }
- }
- set args ""
- set needed [action_needs_portlist $action]
- if {[ACTION_ARGS_STRINGS] == $needed} {
- set args " <arguments>"
- } elseif {[ACTION_ARGS_STRINGS] == $needed} {
- set args " <portlist>"
- }
-
- set ret "Usage: "
- set len [string length $action]
- append ret [wrap "$action$cmds$args" 0 [string repeat " " [expr {8 + $len}]] 0]
- append ret "\n"
-
- return $ret
- }
-
- return -1
-}
-
-proc action_usage { action portlist opts } {
- if {[llength $portlist] == 0} {
- print_usage
- return 0
- }
-
- foreach topic $portlist {
- set usage [action_get_usage $topic]
- if {$usage != -1} {
- puts -nonewline stderr $usage
- } else {
- ui_error "No usage for topic $topic"
- return 1
- }
- }
- return 0
-}
-
-
-proc action_help { action portlist opts } {
- set helpfile "$macports::prefix/var/macports/port-help.tcl"
-
- if {[llength $portlist] == 0} {
- print_help
- return 0
- }
-
- if {[file exists $helpfile]} {
- if {[catch {source $helpfile} err]} {
- puts stderr "Error reading helpfile $helpfile: $err"
- return 1
- }
- } else {
- puts stderr "Unable to open help file $helpfile"
- return 1
- }
-
- foreach topic $portlist {
- if {![info exists porthelp($topic)]} {
- puts stderr "No help for topic $topic"
- return 1
- }
-
- set usage [action_get_usage $topic]
- if {$usage != -1} {
- puts -nonewline stderr $usage
- } else {
- ui_error "No usage for topic $topic"
- return 1
- }
-
- puts stderr $porthelp($topic)
- }
-
- return 0
-}
-
-
-proc action_log { action portlist opts } {
- global global_options
- if {[require_portlist portlist]} {
- return 1
- }
- foreachport $portlist {
- # If we have a url, use that, since it's most specific
- # otherwise try to map the portname to a url
- if {$porturl eq ""} {
- # Verify the portname, getting portinfo to map to a porturl
- if {[catch {mportlookup $portname} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Port $portname not found" 1 status
- }
- array unset portinfo
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
- set portdir $portinfo(portdir)
- set portname $portinfo(name)
- } elseif {$porturl ne "file://."} {
- # Extract the portdir from porturl and use it to search PortIndex.
- # Only the last two elements of the path (porturl) make up the
- # portdir.
- set portdir [file split [macports::getportdir $porturl]]
- set lsize [llength $portdir]
- set portdir \
- [file join [lindex $portdir [expr {$lsize - 2}]] \
- [lindex $portdir [expr {$lsize - 1}]]]
- if {[catch {mportsearch $portdir no exact portdir} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Portdir $portdir not found" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Portdir $portdir not found" 1 status
- }
- array unset portinfo
- set matchindex [lsearch -exact -nocase $result $portname]
- if {$matchindex != -1} {
- array set portinfo [lindex $result [incr matchindex]]
- } else {
- ui_warn "Portdir $portdir doesn't seem to belong to portname $portname"
- array set portinfo [lindex $result 1]
- }
- set portname $portinfo(name)
- }
- set portpath [macports::getportdir $porturl]
- set logfile [file join [macports::getportlogpath $portpath $portname] "main.log"]
- if {[file exists $logfile]} {
- if {[catch {set fp [open $logfile r]} result]} {
- break_softcontinue "Could not open file $logfile: $result" 1 status
- }
- set data [read $fp]
- set data [split $data "\n"]
-
- if {[info exists global_options(ports_log_phase)]} {
- set phase $global_options(ports_log_phase);
- } else {
- set phase "\[a-z\]*"
- }
-
- if {[info exists global_options(ports_log_level)]} {
- set index [lsearch -exact ${macports::ui_priorities} $global_options(ports_log_level)]
- if {$index == -1} {
- set prefix ""
- } else {
- set prefix [join [lrange ${macports::ui_priorities} 0 $index] "|"]
- }
- } else {
- set prefix "\[a-z\]*"
- }
- foreach line $data {
- set exp "^:($prefix|any):($phase|any) (.*)$"
- if {[regexp $exp $line -> lpriority lphase lmsg] == 1} {
- puts "[macports::ui_prefix_default $lpriority]$lmsg"
- }
- }
-
- close $fp
- } else {
- break_softcontinue "Log file for port $portname not found" 1 status
- }
- }
- return 0
-}
-
-
-proc action_info { action portlist opts } {
- global global_variations
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
-
- set separator ""
- foreachport $portlist {
- set index_only 0
- if {[info exists options(ports_info_index)] && $options(ports_info_index)} {
- set index_only 1
- }
- puts -nonewline $separator
- array unset portinfo
- # If we have a url, use that, since it's most specific
- # otherwise try to map the portname to a url
- if {$porturl eq "" || $index_only} {
- # Verify the portname, getting portinfo to map to a porturl
- if {[catch {mportlookup $portname} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Port $portname not found" 1 status
- }
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
- set portdir $portinfo(portdir)
- }
-
- if {!$index_only} {
- # Add any global_variations to the variations
- # specified for the port (so we get e.g. dependencies right)
- array unset merged_variations
- array set merged_variations [array get variations]
- foreach { variation value } [array get global_variations] {
- if { ![info exists merged_variations($variation)] } {
- set merged_variations($variation) $value
- }
- }
- if {![info exists options(subport)]} {
- if {[info exists portinfo(name)]} {
- set options(subport) $portinfo(name)
- } else {
- set options(subport) $portname
- }
- }
-
- if {[catch {set mport [mportopen $porturl [array get options] [array get merged_variations]]} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Unable to open port: $result" 1 status
- }
- unset options(subport)
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
- if {[info exists portdir]} {
- set portinfo(portdir) $portdir
- }
- } elseif {![info exists portinfo]} {
- ui_warn "no PortIndex entry found for $portname"
- continue
- }
- array unset options ports_info_index
-
- # Understand which info items are actually lists
- # (this could be overloaded to provide a generic formatting code to
- # allow us to, say, split off the prefix on libs)
- array set list_map "
- categories 1
- depends_fetch 1
- depends_extract 1
- depends_build 1
- depends_lib 1
- depends_run 1
- maintainers 1
- platforms 1
- variants 1
- conflicts 1
- subports 1
- "
-
- # Label map for pretty printing
- array set pretty_label {
- heading ""
- variants Variants
- depends_fetch "Fetch Dependencies"
- depends_extract "Extract Dependencies"
- depends_build "Build Dependencies"
- depends_run "Runtime Dependencies"
- depends_lib "Library Dependencies"
- description "Brief Description"
- long_description "Description"
- fullname "Full Name: "
- homepage Homepage
- platforms Platforms
- maintainers Maintainers
- license License
- conflicts "Conflicts with"
- replaced_by "Replaced by"
- subports "Sub-ports"
- }
-
- # Wrap-length map for pretty printing
- array set pretty_wrap {
- heading 0
- replaced_by 22
- variants 22
- depends_fetch 22
- depends_extract 22
- depends_build 22
- depends_run 22
- depends_lib 22
- description 22
- long_description 22
- homepage 22
- platforms 22
- license 22
- conflicts 22
- maintainers 22
- subports 22
- }
-
- # Interpret a convenient field abbreviation
- if {[info exists options(ports_info_depends)] && $options(ports_info_depends) eq "yes"} {
- array unset options ports_info_depends
- set options(ports_info_depends_fetch) yes
- set options(ports_info_depends_extract) yes
- set options(ports_info_depends_build) yes
- set options(ports_info_depends_lib) yes
- set options(ports_info_depends_run) yes
- }
-
- # Set up our field separators
- set show_label 1
- set field_sep "\n"
- set subfield_sep ", "
- set pretty_print 0
-
- # For human-readable summary, which is the default with no options
- if {[llength [array get options ports_info_*]] == 0} {
- set pretty_print 1
- } elseif {[info exists options(ports_info_pretty)]} {
- set pretty_print 1
- array unset options ports_info_pretty
- }
-
- # Tune for sort(1)
- if {[info exists options(ports_info_line)]} {
- array unset options ports_info_line
- set noseparator 1
- set show_label 0
- set field_sep "\t"
- set subfield_sep ","
- }
-
- # Figure out whether to show field name
- set quiet [macports::ui_isset ports_quiet]
- if {$quiet} {
- set show_label 0
- }
- # In pretty-print mode we also suppress messages, even though we show
- # most of the labels:
- if {$pretty_print} {
- set quiet 1
- }
-
- # Spin through action options, emitting information for any found
- set fields {}
- set opts_todo [array names options ports_info_*]
- set fields_tried {}
- if {![llength $opts_todo]} {
- set opts_todo {ports_info_heading
- ports_info_replaced_by
- ports_info_subports
- ports_info_variants
- ports_info_skip_line
- ports_info_long_description ports_info_homepage
- ports_info_skip_line ports_info_depends_fetch
- ports_info_depends_extract ports_info_depends_build
- ports_info_depends_lib ports_info_depends_run
- ports_info_conflicts
- ports_info_platforms ports_info_license
- ports_info_maintainers
- }
- }
- foreach { option } $opts_todo {
- set opt [string range $option 11 end]
- # Artificial field name for formatting
- if {$pretty_print && $opt eq "skip_line"} {
- lappend fields ""
- continue
- }
- # Artificial field names to reproduce prettyprinted summary
- if {$opt eq "heading"} {
- set inf "$portinfo(name) @$portinfo(version)"
- set ropt "heading"
- if {[info exists portinfo(revision)] && $portinfo(revision) > 0} {
- append inf "_$portinfo(revision)"
- }
- if {[info exists portinfo(categories)]} {
- append inf " ([join $portinfo(categories) ", "])"
- }
- } elseif {$opt eq "fullname"} {
- set inf "$portinfo(name) @"
- append inf [composite_version $portinfo(version) $portinfo(active_variants)]
- set ropt "fullname"
- } else {
- # Map from friendly name
- set ropt [map_friendly_field_names $opt]
-
- # If there's no such info, move on
- if {![info exists portinfo($ropt)]} {
- set inf ""
- } else {
- set inf [join $portinfo($ropt)]
- }
- }
-
- # Calculate field label
- set label ""
- if {$pretty_print} {
- if {[info exists pretty_label($ropt)]} {
- set label $pretty_label($ropt)
- } else {
- set label $opt
- }
- } elseif {$show_label} {
- set label "$opt: "
- }
-
- # Format the data
- if { $ropt eq "maintainers" } {
- set inf [unobscure_maintainers $inf]
- }
- # ... special formatting for certain fields when prettyprinting
- if {$pretty_print} {
- if {$ropt eq "variants"} {
- # Use the new format for variants iff it exists in
- # PortInfo. This key currently does not exist outside of
- # trunk (1.8.0).
- array unset vinfo
- if {[info exists portinfo(vinfo)]} {
- array set vinfo $portinfo(vinfo)
- }
-
- set pi_vars $inf
- set inf {}
- foreach v [lsort $pi_vars] {
- set varmodifier ""
- if {[info exists variations($v)]} {
- # selected by command line, prefixed with +/-
- set varmodifier $variations($v)
- } elseif {[info exists global_variations($v)]} {
- # selected by variants.conf, prefixed with (+)/(-)
- set varmodifier "($global_variations($v))"
- # Retrieve additional information from the new key.
- } elseif {[info exists vinfo]} {
- array unset variant
- array set variant $vinfo($v)
- if {[info exists variant(is_default)]} {
- set varmodifier "\[$variant(is_default)]"
- }
- }
- lappend inf "$varmodifier$v"
- }
- } elseif {[string match "depend*" $ropt]
- && ![macports::ui_isset ports_verbose]} {
- set pi_deps $inf
- set inf {}
- foreach d $pi_deps {
- lappend inf [lindex [split $d :] end]
- }
- }
- }
- #End of special pretty-print formatting for certain fields
- if {[info exists list_map($ropt)]} {
- set field [join $inf $subfield_sep]
- } else {
- set field $inf
- }
-
- # Assemble the entry
- if {$pretty_print} {
- # The two special fields are considered headings and are
- # emitted immediately, rather than waiting. Also they are not
- # recorded on the list of fields tried
- if {$ropt eq "heading" || $ropt eq "fullname"} {
- puts "$label$field"
- continue
- }
- }
- lappend fields_tried $label
- if {$pretty_print} {
- if {$field eq ""} {
- continue
- }
- if {$label eq ""} {
- set wrap_len 0
- if {[info exists pretty_wrap($ropt)]} {
- set wrap_len $pretty_wrap($ropt)
- }
- lappend fields [wrap $field 0 [string repeat " " $wrap_len]]
- } else {
- set wrap_len [string length $label]
- if {[info exists pretty_wrap($ropt)]} {
- set wrap_len $pretty_wrap($ropt)
- }
- lappend fields [wraplabel $label $field 0 [string repeat " " $wrap_len]]
- }
-
- } else { # Not pretty print
- lappend fields "$label$field"
- }
- }
-
- # Now output all that information:
- if {[llength $fields]} {
- puts [join $fields $field_sep]
- } else {
- if {$pretty_print && [llength $fields_tried]} {
- puts -nonewline "$portinfo(name) has no "
- puts [join $fields_tried ", "]
- }
- }
- if {![info exists noseparator]} {
- set separator "--\n"
- }
- }
-
- return $status
-}
-
-
-proc action_location { action portlist opts } {
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
- foreachport $portlist {
- if { [catch {set ilist [registry_installed $portname [composite_version $portversion [array get variations]]]} result] } {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port location failed: $result" 1 status
- } else {
- # set portname again since the one we were passed may not have had the correct case
- set portname [lindex $ilist 0]
- set version [lindex $ilist 1]
- set revision [lindex $ilist 2]
- set variants [lindex $ilist 3]
- set epoch [lindex $ilist 5]
- }
-
- set ref [registry::open_entry $portname $version $revision $variants $epoch]
- set imagedir [registry::property_retrieve $ref location]
- ui_notice "Port $portname ${version}_${revision}${variants} is installed as an image in:"
- puts $imagedir
- }
-
- return $status
-}
-
-
-proc action_notes { action portlist opts } {
- if {[require_portlist portlist]} {
- return 1
- }
-
- set status 0
- foreachport $portlist {
- array unset portinfo
- if {$porturl eq ""} {
- # Look up the port.
- if {[catch {mportlookup $portname} result]} {
- ui_debug $::errorInfo
- break_softcontinue "The lookup of '$portname' failed: $result" \
- 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "The port '$portname' was not found" 1 status
- }
-
- # Retrieve the port's URL.
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
- }
-
- # Add any global_variations to the variations
- # specified for the port
- array unset merged_variations
- array set merged_variations [array get variations]
- foreach { variation value } [array get global_variations] {
- if { ![info exists merged_variations($variation)] } {
- set merged_variations($variation) $value
- }
- }
- if {![info exists options(subport)]} {
- if {[info exists portinfo(name)]} {
- set options(subport) $portinfo(name)
- } else {
- set options(subport) $portname
- }
- }
-
- # Open the Portfile associated with this port.
- if {[catch {set mport [mportopen $porturl [array get options] \
- [array get merged_variations]]} \
- result]} {
- ui_debug $::errorInfo
- break_softcontinue [concat "The URL '$porturl' could not be" \
- "opened: $result"] 1 status
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
-
- # Return the notes associated with this Portfile.
- if {[info exists portinfo(notes)]} {
- set portnotes $portinfo(notes)
- } else {
- set portnotes {}
- }
-
- # Retrieve the port's name once more to ensure it has the proper case.
- set portname $portinfo(name)
-
- # Display the notes.
- if {$portnotes ne {}} {
- ui_notice "$portname has the following notes:"
- foreach note $portnotes {
- puts [wrap $note 0 " " 1]
- }
- } else {
- puts "$portname has no notes."
- }
- }
- return $status
-}
-
-
-proc action_provides { action portlist opts } {
- # In this case, portname is going to be used for the filename... since
- # that is the first argument we expect... perhaps there is a better way
- # to do this?
- if { ![llength $portlist] } {
- ui_error "Please specify a filename to check which port provides that file."
- return 1
- }
- foreach filename $portlist {
- set file [file normalize $filename]
- if {[file exists $file] || ![catch {file type $file}]} {
- if {![file isdirectory $file] || [file type $file] eq "link"} {
- set port [registry::file_registered $file]
- if { $port != 0 } {
- puts "$file is provided by: $port"
- } else {
- puts "$file is not provided by a MacPorts port."
- }
- } else {
- puts "$file is a directory."
- }
- } else {
- puts "$file does not exist."
- }
- }
- registry::close_file_map
-
- return 0
-}
-
-
-proc action_activate { action portlist opts } {
- set status 0
- if {[require_portlist portlist] || [prefix_unwritable]} {
- return 1
- }
- foreachport $portlist {
- set composite_version [composite_version $portversion [array get variations]]
- if {![info exists options(ports_activate_no-exec)]
- && ![catch {set ilist [registry::installed $portname $composite_version]}]
- && [llength $ilist] == 1} {
-
- set i [lindex $ilist 0]
- set regref [registry::entry open $portname [lindex $i 1] [lindex $i 2] [lindex $i 3] [lindex $i 5]]
- if {[$regref installtype] eq "image" && [registry::run_target $regref activate [array get options]]} {
- continue
- }
- }
- if {![macports::global_option_isset ports_dryrun]} {
- if { [catch {portimage::activate_composite $portname $composite_version [array get options]} result] } {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port activate failed: $result" 1 status
- }
- } else {
- ui_msg "Skipping activate $portname (dry run)"
- }
- }
-
- return $status
-}
-
-
-proc action_deactivate { action portlist opts } {
- set status 0
- if {[require_portlist portlist] || [prefix_unwritable]} {
- return 1
- }
- set portlist [portlist_sortdependents $portlist]
- foreachport $portlist {
- set composite_version [composite_version $portversion [array get variations]]
- if {![info exists options(ports_deactivate_no-exec)]
- && ![catch {set ilist [registry::active $portname]}]} {
-
- set i [lindex $ilist 0]
- set iversion [lindex $i 1]
- set irevision [lindex $i 2]
- set ivariants [lindex $i 3]
- if {$composite_version eq "" || $composite_version == "${iversion}_${irevision}${ivariants}"} {
- set regref [registry::entry open $portname $iversion $irevision $ivariants [lindex $i 5]]
- if {[$regref installtype] eq "image" && [registry::run_target $regref deactivate [array get options]]} {
- continue
- }
- }
- }
- if {![macports::global_option_isset ports_dryrun]} {
- if { [catch {portimage::deactivate_composite $portname $composite_version [array get options]} result] } {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port deactivate failed: $result" 1 status
- }
- } else {
- ui_msg "Skipping deactivate $portname (dry run)"
- }
- }
-
- return $status
-}
-
-
-proc action_select { action portlist opts } {
- ui_debug "action_select \[$portlist] \[$opts]..."
-
- array set opts_array $opts
- set commands [array names opts_array ports_select_*]
- array unset opts_array
-
- # Error out if no group is specified or command is not --summary.
- if {[llength $portlist] < 1 && [string map {ports_select_ ""} [lindex $commands 0]] != "summary"} {
- ui_error "port select \[--list|--set|--show|--summary] \<group> \[<version>]"
- return 1
- }
-
- set group [lindex $portlist 0]
-
- # If no command (--set, --show, --list, --summary) is specified *but*
- # more than one argument is specified, default to the set command.
- if {[llength $commands] < 1 && [llength $portlist] > 1} {
- set command set
- ui_debug [concat "Although no command was specified, more than " \
- "one argument was specified. Defaulting to the " \
- "'set' command..."]
- # If no command (--set, --show, --list) is specified *and* less than two
- # argument are specified, default to the list command.
- } elseif {[llength $commands] < 1} {
- set command list
- ui_debug [concat "No command was specified. Defaulting to the " \
- "'list' command..."]
- # Only allow one command to be specified at a time.
- } elseif {[llength $commands] > 1} {
- ui_error [concat "Multiple commands were specified. Only one " \
- "command may be specified at a time."]
- return 1
- } else {
- set command [string map {ports_select_ ""} [lindex $commands 0]]
- ui_debug "The '$command' command was specified."
- }
-
- switch -- $command {
- list {
- if {[llength $portlist] > 1} {
- ui_warn [concat "The 'list' command does not expect any " \
- "arguments. Extra arguments will be ignored."]
- }
-
- if {[catch {mportselect show $group} selected_version]} {
- global errorInfo
- ui_debug $errorInfo
- ui_warn "Unable to get active selected version: $selected_version"
- }
-
- # On error mportselect returns with the code 'error'.
- if {[catch {mportselect $command $group} versions]} {
- ui_error "The 'list' command failed: $versions"
- return 1
- }
-
- ui_notice "Available versions for $group:"
- foreach v $versions {
- ui_notice -nonewline "\t"
- if {$selected_version == $v} {
- ui_msg "$v (active)"
- } else {
- ui_msg "$v"
- }
- }
- return 0
- }
- set {
- if {[llength $portlist] < 2} {
- ui_error [concat "The 'set' command expects two " \
- "arguments: <group>, <version>"]
- return 1
- } elseif {[llength $portlist] > 2} {
- ui_warn [concat "The 'set' command only expects two " \
- "arguments. Extra arguments will be " \
- "ignored."]
- }
- set version [lindex $portlist 1]
-
- ui_msg -nonewline "Selecting '$version' for '$group' "
- if {[catch {mportselect $command $group $version} result]} {
- ui_msg "failed: $result"
- return 1
- }
- ui_msg "succeeded. '$version' is now active."
- return 0
- }
- show {
- if {[llength $portlist] > 1} {
- ui_warn [concat "The 'show' command does not expect any " \
- "arguments. Extra arguments will be ignored."]
- }
-
- if {[catch {mportselect $command $group} selected_version]} {
- ui_error "The 'show' command failed: $selected_version"
- return 1
- }
- puts [concat "The currently selected version for '$group' is " \
- "'$selected_version'."]
- return 0
- }
- summary {
- if {[llength $portlist] > 0} {
- ui_warn [concat "The 'summary' command does not expect any " \
- "arguments. Extra arguments will be ignored."]
- }
-
- if {[catch {mportselect $command} portgroups]} {
- ui_error "The 'summary' command failed: $portgroups"
- return 1
- }
-
- set w1 4
- set w2 8
- set formatStr "%-*s %-*s %s"
-
- set groups [list]
- foreach pg $portgroups {
- array set groupdesc {}
- set groupdesc(name) [string trim $pg]
-
- if {[catch {mportselect list $pg} versions]} {
- ui_warn "The list of options for the select group $pg could not be obtained: $versions"
- continue
- }
- # remove "none", sort the list, append none at the end
- set noneidx [lsearch -exact $versions "none"]
- set versions [lsort [lreplace $versions $noneidx $noneidx]]
- lappend versions "none"
- set groupdesc(versions) $versions
-
- if {[catch {mportselect show $pg} selected_version]} {
- ui_warn "The currently selected option for the select group $pg could not be obtained: $selected_version"
- continue
- }
- set groupdesc(selected) $selected_version
-
- set w1 [expr {max($w1, [string length $pg])}]
- set w2 [expr {max($w2, [string length $selected_version])}]
-
- lappend groups [array get groupdesc]
- array unset groupdesc
- }
- puts [format $formatStr $w1 "Name" $w2 "Selected" "Options"]
- puts [format $formatStr $w1 "====" $w2 "========" "======="]
- foreach groupdesc $groups {
- array set groupd $groupdesc
- puts [format $formatStr $w1 $groupd(name) $w2 $groupd(selected) [join $groupd(versions) " "]]
- array unset groupd
- }
- return 0
- }
- default {
- ui_error "An unknown command '$command' was specified."
- return 1
- }
- }
-}
-
-
-proc action_selfupdate { action portlist opts } {
- global global_options
- if { [catch {macports::selfupdate [array get global_options] base_updated} result ] } {
- global errorInfo
- ui_debug "$errorInfo"
- ui_error "$result"
- if {![macports::ui_isset ports_verbose]} {
- ui_msg "Please run `port -v selfupdate' for details."
- } else {
- # Let's only print the ticket URL if the user has followed the
- # advice we printed earlier.
- print_tickets_url
- }
- fatal "port selfupdate failed: $result"
- }
-
- if {$base_updated} {
- # exit immediately if in batch/interactive mode
- return -999
- } else {
- return 0
- }
-}
-
-
-proc action_setrequested { action portlist opts } {
- set status 0
- if {[require_portlist portlist] || [prefix_unwritable]} {
- return 1
- }
- # set or unset?
- set val [string equal $action "setrequested"]
- foreachport $portlist {
- set composite_version [composite_version $portversion [array get variations]]
- if {![catch {set ilist [registry::installed $portname $composite_version]} result]} {
- ui_info "Setting requested flag for $portname to $val"
- foreach i $ilist {
- set regref [registry::open_entry $portname [lindex $i 1] [lindex $i 2] [lindex $i 3] [lindex $i 5]]
- registry::property_store $regref requested $val
- }
- } else {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "$result" 1 status
- }
- }
-
- return $status
-}
-
-
-proc action_upgrade { action portlist opts } {
- if {[require_portlist portlist "yes"] || ([prefix_unwritable] && ![macports::global_option_isset ports_dryrun])} {
- return 1
- }
-
- # shared depscache for all ports in the list
- array set depscache {}
- set status 0
- foreachport $portlist {
- if {![info exists depscache(port:$portname)]} {
- set status [macports::upgrade $portname "port:$portname" [array get requested_variations] [array get options] depscache]
- # status 2 means the port was not found in the index,
- # status 3 means the port is not installed
- if {$status != 0 && $status != 2 && $status != 3 && ![macports::ui_isset ports_processall]} {
- break
- }
- }
- }
-
- if {$status != 0 && $status != 2 && $status != 3} {
- print_tickets_url
- } elseif {$status == 0} {
- array set options $opts
- if {![info exists options(ports_upgrade_no-rev-upgrade)] && ${macports::revupgrade_autorun} && ![macports::global_option_isset ports_dryrun]} {
- set status [action_revupgrade $action $portlist $opts]
- }
- }
-
- return $status
-}
-
-proc action_doctor { action portlist opts } {
-<<<<<<< HEAD
- macports::doctor_main
-=======
- if {[prefix_unwritable]} {
- return 1
- }
- macports::doctor_main $opts
->>>>>>> svn
- return 0
-}
-
-proc action_reclaim { action portlist opts } {
-<<<<<<< HEAD
-=======
- if {[prefix_unwritable]} {
- return 1
- }
->>>>>>> svn
- macports::reclaim_main
- return 0
-}
-
-proc action_revupgrade { action portlist opts } {
- set status [macports::revupgrade $opts]
- if {$status != 0} {
- print_tickets_url
- }
- return $status
-}
-
-
-proc action_version { action portlist opts } {
- if {![macports::ui_isset ports_quiet]} {
- puts -nonewline "Version: "
- }
- puts [macports::version]
- return 0
-}
-
-
-proc action_platform { action portlist opts } {
- if {![macports::ui_isset ports_quiet]} {
- puts -nonewline "Platform: "
- }
- puts "${macports::os_platform} ${macports::os_major} ${macports::os_arch}"
- return 0
-}
-
-
-proc action_dependents { action portlist opts } {
- if {[require_portlist portlist]} {
- return 1
- }
- set ilist {}
-
- registry::open_dep_map
-
- set status 0
- foreachport $portlist {
- set composite_version [composite_version $portversion [array get variations]]
- if { [catch {set ilist [registry::installed $portname $composite_version]} result] } {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "$result" 1 status
- } else {
- # choose the active version if there is one
- set index 0
- foreach i $ilist {
- if {[lindex $i 4]} {
- set found 1
- break
- }
- incr index
- }
- if {![info exists found]} {
- set index 0
- }
- # set portname again since the one we were passed may not have had the correct case
- set portname [lindex $ilist $index 0]
- set iversion [lindex $ilist $index 1]
- set irevision [lindex $ilist $index 2]
- set ivariants [lindex $ilist $index 3]
- }
-
- set deplist [registry::list_dependents $portname $iversion $irevision $ivariants]
- if { [llength $deplist] > 0 } {
- if {$action eq "rdependents"} {
- set toplist $deplist
- while 1 {
- set newlist {}
- foreach dep $deplist {
- set depname [lindex $dep 2]
- if {![info exists seen($depname)]} {
- set seen($depname) 1
- set rdeplist [registry::list_dependents $depname]
- foreach rdep $rdeplist {
- lappend newlist $rdep
- }
- set dependentsof($depname) $rdeplist
- }
- }
- if {[llength $newlist] > 0} {
- set deplist $newlist
- } else {
- break
- }
- }
- set portstack [list $toplist]
- set pos_stack [list 0]
- array unset seen
- ui_notice "The following ports are dependent on ${portname}:"
- while 1 {
- set cur_portlist [lindex $portstack end]
- set cur_pos [lindex $pos_stack end]
- if {$cur_pos >= [llength $cur_portlist]} {
- set portstack [lreplace $portstack end end]
- set pos_stack [lreplace $pos_stack end end]
- if {[llength $portstack] <= 0} {
- break
- } else {
- continue
- }
- }
- set cur_port [lindex $cur_portlist $cur_pos]
- set cur_portname [lindex $cur_port 2]
- set spaces [string repeat " " [expr {[llength $pos_stack] * 2}]]
- if {![info exists seen($cur_portname)] || ([info exists options(ports_rdependents_full)] && [string is true -strict $options(ports_rdependents_full)])} {
- puts "${spaces}${cur_portname}"
- set seen($cur_portname) 1
- incr cur_pos
- set pos_stack [lreplace $pos_stack end end $cur_pos]
- if {[info exists dependentsof($cur_portname)]} {
- lappend portstack $dependentsof($cur_portname)
- lappend pos_stack 0
- }
- continue
- }
- incr cur_pos
- set pos_stack [lreplace $pos_stack end end $cur_pos]
- }
- } else {
- foreach dep $deplist {
- set depport [lindex $dep 2]
- if {[macports::ui_isset ports_quiet]} {
- ui_msg "$depport"
- } elseif {![macports::ui_isset ports_verbose]} {
- ui_msg "$depport depends on $portname"
- } else {
- ui_msg "$depport depends on $portname (by [lindex $dep 1]:)"
- }
- }
- }
- } else {
- ui_notice "$portname has no dependents."
- }
- }
- return $status
-}
-
-
-proc action_deps { action portlist opts } {
- global global_variations
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
- set separator ""
-
- foreachport $portlist {
- if {[info exists options(ports_${action}_no-build)] && [string is true -strict $options(ports_${action}_no-build)]} {
- set deptypes {depends_lib depends_run}
- } else {
- set deptypes {depends_fetch depends_extract depends_build depends_lib depends_run}
- }
-
- array unset portinfo
- # If we have a url, use that, since it's most specific
- # otherwise try to map the portname to a url
- if {$porturl eq ""} {
- # Verify the portname, getting portinfo to map to a porturl
- if {[catch {mportlookup $portname} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Port $portname not found" 1 status
- }
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
- } elseif {$porturl ne "file://."} {
- # Extract the portdir from porturl and use it to search PortIndex.
- # Only the last two elements of the path (porturl) make up the
- # portdir.
- set portdir [file split [macports::getportdir $porturl]]
- set lsize [llength $portdir]
- set portdir \
- [file join [lindex $portdir [expr {$lsize - 2}]] \
- [lindex $portdir [expr {$lsize - 1}]]]
- if {[catch {mportsearch $portdir no exact portdir} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Portdir $portdir not found" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Portdir $portdir not found" 1 status
- }
- set matchindex [lsearch -exact -nocase $result $portname]
- if {$matchindex != -1} {
- array set portinfo [lindex $result [incr matchindex]]
- } else {
- ui_warn "Portdir $portdir doesn't seem to belong to portname $portname"
- array set portinfo [lindex $result 1]
- }
- }
-
- if {!([info exists options(ports_${action}_index)] && $options(ports_${action}_index) eq "yes")} {
- # Add any global_variations to the variations
- # specified for the port, so we get dependencies right
- array unset merged_variations
- array set merged_variations [array get variations]
- foreach { variation value } [array get global_variations] {
- if { ![info exists merged_variations($variation)] } {
- set merged_variations($variation) $value
- }
- }
- if {![info exists options(subport)]} {
- if {[info exists portinfo(name)]} {
- set options(subport) $portinfo(name)
- } else {
- set options(subport) $portname
- }
- }
- if {[catch {set mport [mportopen $porturl [array get options] [array get merged_variations]]} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Unable to open port: $result" 1 status
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
- } elseif {![info exists portinfo]} {
- ui_warn "port ${action} --index does not work with the 'current' pseudo-port"
- continue
- }
- set portname $portinfo(name)
-
- set deplist {}
- set deps_output {}
- set ndeps 0
- array set labeldict {depends_fetch Fetch depends_extract Extract depends_build Build depends_lib Library depends_run Runtime}
- # get list of direct deps
- foreach type $deptypes {
- if {[info exists portinfo($type)]} {
- if {$action eq "rdeps" || [macports::ui_isset ports_verbose]} {
- foreach dep $portinfo($type) {
- lappend deplist $dep
- }
- } else {
- foreach dep $portinfo($type) {
- lappend deplist [lindex [split $dep :] end]
- }
- }
- if {$action eq "deps"} {
- set label "$labeldict($type) Dependencies"
- lappend deps_output [wraplabel $label [join $deplist ", "] 0 [string repeat " " 22]]
- incr ndeps [llength $deplist]
- set deplist {}
- }
- }
- }
-
- set version $portinfo(version)
- set revision $portinfo(revision)
- if {[info exists portinfo(canonical_active_variants)]} {
- set variants $portinfo(canonical_active_variants)
- } else {
- set variants {}
- }
-
- puts -nonewline $separator
- if {$action eq "deps"} {
- if {$ndeps == 0} {
- ui_notice "$portname @${version}_${revision}${variants} has no dependencies."
- } else {
- ui_notice "Full Name: $portname @${version}_${revision}${variants}"
- puts [join $deps_output "\n"]
- }
- set separator "--\n"
- continue
- }
-
- set toplist $deplist
- # gather all the deps
- while 1 {
- set newlist {}
- foreach dep $deplist {
- set depname [lindex [split $dep :] end]
- if {![info exists seen($depname)]} {
- set seen($depname) 1
-
- # look up the dep
- if {[catch {mportlookup $depname} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "lookup of portname $depname failed: $result" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Port $depname not found" 1 status
- }
- array unset portinfo
- array set portinfo [lindex $result 1]
- set porturl $portinfo(porturl)
- set options(subport) $portinfo(name)
-
- # open the portfile if requested
- if {!([info exists options(ports_${action}_index)] && $options(ports_${action}_index) eq "yes")} {
- if {[catch {set mport [mportopen $porturl [array get options] [array get merged_variations]]} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Unable to open port: $result" 1 status
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
- }
-
- # get list of the dep's deps
- set rdeplist {}
- foreach type $deptypes {
- if {[info exists portinfo($type)]} {
- foreach rdep $portinfo($type) {
- lappend rdeplist $rdep
- lappend newlist $rdep
- }
- }
- }
- set depsof($depname) $rdeplist
- }
- }
- if {[llength $newlist] > 0} {
- set deplist $newlist
- } else {
- break
- }
- }
- set portstack [list $toplist]
- set pos_stack [list 0]
- array unset seen
- if {[llength $toplist] > 0} {
- ui_notice "The following ports are dependencies of $portname @${version}_${revision}${variants}:"
- } else {
- ui_notice "$portname @${version}_${revision}${variants} has no dependencies."
- }
- while 1 {
- set cur_portlist [lindex $portstack end]
- set cur_pos [lindex $pos_stack end]
- if {$cur_pos >= [llength $cur_portlist]} {
- set portstack [lreplace $portstack end end]
- set pos_stack [lreplace $pos_stack end end]
- if {[llength $portstack] <= 0} {
- break
- } else {
- continue
- }
- }
- set cur_port [lindex $cur_portlist $cur_pos]
- set cur_portname [lindex [split $cur_port :] end]
- set spaces [string repeat " " [expr {[llength $pos_stack] * 2}]]
- if {![info exists seen($cur_portname)] || ([info exists options(ports_${action}_full)] && [string is true -strict $options(ports_${action}_full)])} {
- if {[macports::ui_isset ports_verbose]} {
- puts "${spaces}${cur_port}"
- } else {
- puts "${spaces}${cur_portname}"
- }
- set seen($cur_portname) 1
- incr cur_pos
- set pos_stack [lreplace $pos_stack end end $cur_pos]
- if {[info exists depsof($cur_portname)]} {
- lappend portstack $depsof($cur_portname)
- lappend pos_stack 0
- }
- continue
- }
- incr cur_pos
- set pos_stack [lreplace $pos_stack end end $cur_pos]
- }
- set separator "--\n"
- }
- return $status
-}
-
-
-proc action_uninstall { action portlist opts } {
- set status 0
- if {[macports::global_option_isset port_uninstall_old]} {
- # if -u then uninstall all inactive ports
- # (union these to any other ports user has in the port list)
- set portlist [opUnion $portlist [get_inactive_ports]]
- } else {
- # Otherwise the user hopefully supplied a portlist, or we'll default to the existing directory
- if {[require_portlist portlist]} {
- return 1
- }
- }
- if {[prefix_unwritable]} {
- return 1
- }
-
- set portlist [portlist_sortdependents $portlist]
-
- foreachport $portlist {
- if {![registry::entry_exists_for_name $portname]} {
- # if the code path arrives here the port either isn't installed, or
- # it doesn't exist at all. We can't be sure, but we can check the
- # portindex whether a port by that name exists (in which case not
- # uninstalling it is probably no problem). If there is no port by
- # that name, alert the user in case of typos.
- ui_info "$portname is not installed"
- if {[catch {set res [mportlookup $portname]} result] || [llength $res] == 0} {
- ui_warn "no such port: $portname, skipping uninstall"
- }
- continue
- }
- set composite_version [composite_version $portversion [array get variations]]
- if {![info exists options(ports_uninstall_no-exec)]
- && ![catch {set ilist [registry::installed $portname $composite_version]}]
- && [llength $ilist] == 1} {
-
- set i [lindex $ilist 0]
- set iactive [lindex $i 4]
- set regref [registry::entry open $portname [lindex $i 1] [lindex $i 2] [lindex $i 3] [lindex $i 5]]
- if {[registry::run_target $regref uninstall [array get options]]} {
- continue
- }
- }
-
- if { [catch {registry_uninstall::uninstall_composite $portname $composite_version [array get options]} result] } {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port uninstall failed: $result" 1 status
- }
- }
-
- return $status
-}
-
-
-proc action_installed { action portlist opts } {
- global private_options
- set status 0
- set restrictedList 0
- set ilist {}
-
- if { [llength $portlist] || (![info exists private_options(ports_no_args)] || $private_options(ports_no_args) eq "no")} {
- set restrictedList 1
- foreachport $portlist {
- set composite_version [composite_version $portversion [array get variations]]
- if { [catch {set ilist [concat $ilist [registry::installed $portname $composite_version]]} result] } {
- if {![string match "* not registered as installed." $result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port installed failed: $result" 1 status
- }
- }
- }
- } else {
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- ui_error "port installed failed: $result"
- set status 1
- }
- }
- }
- if { [llength $ilist] > 0 } {
- ui_notice "The following ports are currently installed:"
- foreach i [portlist_sortint $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]
- set extra ""
- set nvariants ""
- if {[macports::ui_isset ports_verbose]} {
- set regref [registry::open_entry $iname $iversion $irevision $ivariants [lindex $i 5]]
- set nvariants [registry::property_retrieve $regref negated_variants]
- if {$nvariants == 0} {
- set nvariants ""
- }
- set os_platform [registry::property_retrieve $regref os_platform]
- set os_major [registry::property_retrieve $regref os_major]
- set archs [registry::property_retrieve $regref archs]
- if {$os_platform != 0 && $os_platform ne "" && $os_major != 0 && $os_major ne ""} {
- append extra " platform='$os_platform $os_major'"
- }
- if {$archs != 0 && $archs ne ""} {
- append extra " archs='$archs'"
- }
- }
- if { $iactive == 0 } {
- puts " $iname @${iversion}_${irevision}${ivariants}${nvariants}${extra}"
- } elseif { $iactive == 1 } {
- puts " $iname @${iversion}_${irevision}${ivariants}${nvariants} (active)${extra}"
- }
- }
- } elseif { $restrictedList } {
- ui_notice "None of the specified ports are installed."
- } else {
- ui_notice "No ports are installed."
- }
-
- return $status
-}
-
-
-proc action_outdated { action portlist opts } {
- global private_options
- set status 0
-
- # If port names were supplied, limit ourselves to those ports, else check all installed ports
- set ilist {}
- set restrictedList 0
- if { [llength $portlist] || (![info exists private_options(ports_no_args)] || $private_options(ports_no_args) eq "no")} {
- set restrictedList 1
- foreach portspec $portlist {
- array set port $portspec
- set portname $port(name)
- set composite_version [composite_version $port(version) $port(variants)]
- if { [catch {set ilist [concat $ilist [registry::installed $portname $composite_version]]} result] } {
- if {![string match "* not registered as installed." $result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "port outdated failed: $result" 1 status
- }
- }
- }
- } else {
- if { [catch {set ilist [registry::installed]} result] } {
- if {$result ne "Registry error: No ports registered as installed."} {
- global errorInfo
- ui_debug "$errorInfo"
- ui_error "port installed failed: $result"
- set status 1
- }
- }
- }
-
- set num_outdated 0
- if { [llength $ilist] > 0 } {
- foreach i [portlist_sortint $ilist] {
-
- # Get information about the installed port
- set portname [lindex $i 0]
- set installed_version [lindex $i 1]
- set installed_revision [lindex $i 2]
- set installed_compound "${installed_version}_${installed_revision}"
-
- set is_active [lindex $i 4]
- if {$is_active == 0} {
- continue
- }
- set installed_epoch [lindex $i 5]
-
- # Get info about the port from the index
- if {[catch {set res [mportlookup $portname]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "search for portname $portname failed: $result" 1 status
- }
- if {[llength $res] < 2} {
- if {[macports::ui_isset ports_debug]} {
- puts "$portname ($installed_compound is installed; the port was not found in the port index)"
- }
- continue
- }
- array unset portinfo
- array set portinfo [lindex $res 1]
-
- # Get information about latest available version and revision
- if {![info exists portinfo(version)]} {
- ui_warn "$portname has no version field"
- continue
- }
- set latest_version $portinfo(version)
- set latest_revision 0
- if {[info exists portinfo(revision)] && $portinfo(revision) > 0} {
- set latest_revision $portinfo(revision)
- }
- set latest_compound "${latest_version}_${latest_revision}"
- set latest_epoch 0
- if {[info exists portinfo(epoch)]} {
- set latest_epoch $portinfo(epoch)
- }
-
- # Compare versions, first checking epoch, then version, then revision
- set epoch_comp_result [expr {$installed_epoch - $latest_epoch}]
- set comp_result [vercmp $installed_version $latest_version]
- if { $comp_result == 0 } {
- set comp_result [expr {$installed_revision - $latest_revision}]
- }
- set reason ""
- if {$epoch_comp_result != 0 && $installed_version != $latest_version} {
- if {($comp_result >= 0 && $epoch_comp_result < 0) || ($comp_result <= 0 && $epoch_comp_result > 0)} {
- set reason { (epoch $installed_epoch $relation $latest_epoch)}
- }
- set comp_result $epoch_comp_result
- } elseif {$comp_result == 0} {
- set regref [registry::open_entry $portname $installed_version $installed_revision [lindex $i 3] $installed_epoch]
- set os_platform_installed [registry::property_retrieve $regref os_platform]
- set os_major_installed [registry::property_retrieve $regref os_major]
- if {$os_platform_installed ne "" && $os_platform_installed != 0
- && $os_major_installed ne "" && $os_major_installed != 0
- && ($os_platform_installed != ${macports::os_platform} || $os_major_installed != ${macports::os_major})} {
- set comp_result -1
- set reason { (platform $os_platform_installed $os_major_installed != ${macports::os_platform} ${macports::os_major})}
- }
- }
-
- # Report outdated (or, for verbose, predated) versions
- if { $comp_result != 0 } {
-
- # Form a relation between the versions
- set flag ""
- if { $comp_result > 0 } {
- set relation ">"
- set flag "!"
- } else {
- set relation "<"
- }
-
- # Emit information
- if {$comp_result < 0 || [macports::ui_isset ports_verbose]} {
-
- if {$num_outdated == 0} {
- ui_notice "The following installed ports are outdated:"
- }
- incr num_outdated
-
- puts [format "%-30s %-24s %1s" $portname "$installed_compound $relation $latest_compound [subst $reason]" $flag]
- }
-
- }
- }
-
- if {$num_outdated == 0} {
- ui_notice "No installed ports are outdated."
- }
- } elseif { $restrictedList } {
- ui_notice "None of the specified ports are outdated."
- } else {
- ui_notice "No ports are installed."
- }
-
- return $status
-}
-
-
-proc action_contents { action portlist opts } {
- global global_options
- if {[require_portlist portlist]} {
- return 1
- }
- if {[info exists global_options(ports_contents_size)]} {
- set units {}
- if {[info exists global_options(ports_contents_units)]} {
- set units [complete_size_units $global_options(ports_contents_units)]
- }
- set outstring {[format "%12s $file" [filesize $file $units]]}
- } else {
- set outstring { $file}
- }
-
- foreachport $portlist {
- if { ![catch {set ilist [registry::installed $portname]} result] } {
- # set portname again since the one we were passed may not have had the correct case
- set portname [lindex $ilist 0 0]
- }
- set files [registry::port_registered $portname]
- if { $files != 0 } {
- if { [llength $files] > 0 } {
- ui_notice "Port $portname contains:"
- foreach file $files {
- puts [subst $outstring]
- }
- } else {
- ui_notice "Port $portname does not contain any files or is not active."
- }
- } else {
- ui_notice "Port $portname is not installed."
- }
- }
- registry::close_file_map
-
- return 0
-}
-
-# expand abbreviations of size units
-proc complete_size_units {units} {
- if {$units eq "K" || $units eq "Ki"} {
- return "KiB"
- } elseif {$units eq "k"} {
- return "kB"
- } elseif {$units eq "Mi"} {
- return "MiB"
- } elseif {$units eq "M"} {
- return "MB"
- } elseif {$units eq "Gi"} {
- return "GiB"
- } elseif {$units eq "G"} {
- return "GB"
- } else {
- return $units
- }
-}
-
-# Show space used by the given ports' files
-proc action_space {action portlist opts} {
- global global_options
- require_portlist portlist
-
- set units {}
- if {[info exists global_options(ports_space_units)]} {
- set units [complete_size_units $global_options(ports_space_units)]
- }
- set spaceall 0.0
- foreachport $portlist {
- set space 0.0
- set files [registry::port_registered $portname]
- if { $files != 0 } {
- if { [llength $files] > 0 } {
- foreach file $files {
- catch {
- set space [expr {$space + [file size $file]}]
- }
- }
- if {![info exists options(ports_space_total)] || $options(ports_space_total) ne "yes"} {
- set msg "[bytesize $space $units] $portname"
- if { $portversion != {} } {
- append msg " @$portversion"
- }
- puts $msg
- }
- set spaceall [expr {$space + $spaceall}]
- } else {
- puts stderr "Port $portname does not contain any file or is not active."
- }
- } else {
- puts stderr "Port $portname is not installed."
- }
- }
- if {[llength $portlist] > 1 || ([info exists options(ports_space_total)] && $options(ports_space_total) eq "yes")} {
- puts "[bytesize $spaceall $units] total"
- }
- return 0
-}
-
-proc action_variants { action portlist opts } {
- global global_variations
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
- foreachport $portlist {
- array unset portinfo
- if {$porturl eq ""} {
- # look up port
- if {[catch {mportlookup $portname} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $result] < 2} {
- break_softcontinue "Port $portname not found" 1 status
- }
-
- array set portinfo [lindex $result 1]
-
- set porturl $portinfo(porturl)
- set portdir $portinfo(portdir)
- }
-
- if {!([info exists options(ports_variants_index)] && $options(ports_variants_index) eq "yes")} {
- if {![info exists options(subport)]} {
- if {[info exists portinfo(name)]} {
- set options(subport) $portinfo(name)
- } else {
- set options(subport) $portname
- }
- }
- if {[catch {set mport [mportopen $porturl [array get options] [array get variations]]} result]} {
- ui_debug "$::errorInfo"
- break_softcontinue "Unable to open port: $result" 1 status
- }
- array unset portinfo
- array set portinfo [mportinfo $mport]
- mportclose $mport
- if {[info exists portdir]} {
- set portinfo(portdir) $portdir
- }
- } elseif {![info exists portinfo]} {
- ui_warn "port variants --index does not work with 'current' pseudo-port"
- continue
- }
-
- # set portname again since the one we were passed may not have had the correct case
- set portname $portinfo(name)
-
- # if this fails the port doesn't have any variants
- if {![info exists portinfo(variants)]} {
- ui_notice "$portname has no variants"
- } else {
- array unset vinfo
- # Use the new format if it exists.
- if {[info exists portinfo(vinfo)]} {
- array set vinfo $portinfo(vinfo)
- # Otherwise fall back to the old format.
- } elseif {[info exists portinfo(variant_desc)]} {
- array set vdescriptions $portinfo(variant_desc)
- }
-
- # print out all the variants
- ui_notice "$portname has the variants:"
- foreach v [lsort $portinfo(variants)] {
- unset -nocomplain vconflicts vdescription vrequires
- set varmodifier " "
- # Retrieve variants' information from the new format.
- if {[info exists vinfo]} {
- array unset variant
- array set variant $vinfo($v)
-
- # Retrieve conflicts, description, is_default, and
- # vrequires.
- if {[info exists variant(conflicts)]} {
- set vconflicts $variant(conflicts)
- }
- if {[info exists variant(description)]} {
- set vdescription $variant(description)
- }
-
- # XXX Keep these varmodifiers in sync with action_info, or create a wrapper for it
- if {[info exists variations($v)]} {
- set varmodifier " $variations($v)"
- } elseif {[info exists global_variations($v)]} {
- # selected by variants.conf, prefixed with (+)/(-)
- set varmodifier "($global_variations($v))"
- } elseif {[info exists variant(is_default)]} {
- set varmodifier "\[$variant(is_default)\]"
- }
- if {[info exists variant(requires)]} {
- set vrequires $variant(requires)
- }
- # Retrieve variants' information from the old format,
- # which only consists of the description.
- } elseif {[info exists vdescriptions($v)]} {
- set vdescription $vdescriptions($v)
- }
-
- if {[info exists vdescription]} {
- puts [wraplabel "$varmodifier$v" [string trim $vdescription] 0 [string repeat " " [expr 5 + [string length $v]]]]
- } else {
- puts "$varmodifier$v"
- }
- if {[info exists vconflicts]} {
- puts " * conflicts with [string trim $vconflicts]"
- }
- if {[info exists vrequires]} {
- puts " * requires [string trim $vrequires]"
- }
- }
- }
- }
-
- return $status
-}
-
-
-proc action_search { action portlist opts } {
- global private_options global_options
- set status 0
- if {![llength $portlist] && [info exists private_options(ports_no_args)] && $private_options(ports_no_args) eq "yes"} {
- ui_error "You must specify a search pattern"
- return 1
- }
-
- # Copy global options as we are going to modify the array
- array set options [array get global_options]
-
- if {[info exists options(ports_search_depends)] && $options(ports_search_depends) eq "yes"} {
- array unset options ports_search_depends
- set options(ports_search_depends_fetch) yes
- set options(ports_search_depends_extract) yes
- set options(ports_search_depends_build) yes
- set options(ports_search_depends_lib) yes
- set options(ports_search_depends_run) yes
- }
-
- # Array to hold given filters
- array set filters {}
- # Default matchstyle
- set filter_matchstyle "none"
- set filter_case no
- foreach { option } [array names options ports_search_*] {
- set opt [string range $option 13 end]
-
- if { $options($option) ne "yes" } {
- continue
- }
- switch -- $opt {
- exact -
- glob {
- set filter_matchstyle $opt
- continue
- }
- regex {
- set filter_matchstyle regexp
- continue
- }
- case-sensitive {
- set filter_case yes
- continue
- }
- line {
- continue
- }
- }
-
- set filters($opt) "yes"
- }
- # Set default search filter if none was given
- if { [array size filters] == 0 } {
- set filters(name) "yes"
- set filters(description) "yes"
- }
-
- set separator ""
- foreach portname $portlist {
- puts -nonewline $separator
-
- set searchstring $portname
- set matchstyle $filter_matchstyle
- if {$matchstyle eq "none"} {
- # Guess if the given string was a glob expression, if not do a substring search
- if {[string first "*" $portname] == -1 && [string first "?" $portname] == -1} {
- set searchstring "*$portname*"
- }
- set matchstyle glob
- }
-
- set res {}
- set portfound 0
- foreach { opt } [array get filters] {
- # Map from friendly name
- set opt [map_friendly_field_names $opt]
-
- if {[catch {eval set matches \[mportsearch \$searchstring $filter_case \$matchstyle $opt\]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "search for name $portname failed: $result" 1 status
- }
-
- set tmp {}
- foreach {name info} $matches {
- add_to_portlist tmp [concat [list name $name] $info]
- }
- set res [opUnion $res $tmp]
- }
- set res [portlist_sort $res]
-
- set joiner ""
- foreach info $res {
- array unset portinfo
- array set portinfo $info
-
- # XXX is this the right place to verify an entry?
- if {![info exists portinfo(name)]} {
- puts stderr "Invalid port entry, missing portname"
- continue
- }
- if {![info exists portinfo(description)]} {
- puts stderr "Invalid port entry for $portinfo(name), missing description"
- continue
- }
- if {![info exists portinfo(version)]} {
- puts stderr "Invalid port entry for $portinfo(name), missing version"
- continue
- }
-
- if {[macports::ui_isset ports_quiet]} {
- puts $portinfo(name)
- } else {
- if {[info exists options(ports_search_line)]
- && $options(ports_search_line) eq "yes"} {
- # check for ports without category, e.g. replaced_by stubs
- if {[info exists portinfo(categories)]} {
- puts "$portinfo(name)\t$portinfo(version)\t$portinfo(categories)\t$portinfo(description)"
- } else {
- # keep two consecutive tabs in order to provide consistent columns' content
- puts "$portinfo(name)\t$portinfo(version)\t\t$portinfo(description)"
- }
- } else {
- puts -nonewline $joiner
-
- puts -nonewline "$portinfo(name) @$portinfo(version)"
- if {[info exists portinfo(revision)] && $portinfo(revision) > 0} {
- puts -nonewline "_$portinfo(revision)"
- }
- if {[info exists portinfo(categories)]} {
- puts -nonewline " ([join $portinfo(categories) ", "])"
- }
- puts ""
- puts [wrap [join $portinfo(description)] 0 [string repeat " " 4]]
- }
- }
-
- set joiner "\n"
- set portfound 1
- }
- if { !$portfound } {
- ui_notice "No match for $portname found"
- } elseif {[llength $res] > 1} {
- if {(![info exists global_options(ports_search_line)]
- || $global_options(ports_search_line) ne "yes")} {
- ui_notice "\nFound [llength $res] ports."
- }
- }
-
- set separator "--\n"
- }
-
- array unset options
- array unset filters
-
- return $status
-}
-
-
-proc action_list { action portlist opts } {
- global private_options
- set status 0
-
- # Default to list all ports if no portnames are supplied
- if { ![llength $portlist] && [info exists private_options(ports_no_args)] && $private_options(ports_no_args) eq "yes"} {
- add_to_portlist portlist [list name "-all-"]
- }
-
- foreachport $portlist {
- if {$portname eq "-all-"} {
- if {[catch {set res [mportlistall]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "listing all ports failed: $result" 1 status
- }
- } else {
- set search_string [regex_pat_sanitize $portname]
- if {[catch {set res [mportsearch ^$search_string\$ no]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "search for portname $search_string failed: $result" 1 status
- }
- }
-
- foreach {name array} $res {
- array unset portinfo
- array set portinfo $array
- set outdir ""
- if {[info exists portinfo(portdir)]} {
- set outdir $portinfo(portdir)
- }
- puts [format "%-30s @%-14s %s" $portinfo(name) $portinfo(version) $outdir]
- }
- }
-
- return $status
-}
-
-
-proc action_echo { action portlist opts } {
- global global_options
-
- # Simply echo back the port specs given to this command
- foreachport $portlist {
- if {![macports::ui_isset ports_quiet]} {
- set opts {}
- foreach { key value } [array get options] {
- if {![info exists global_options($key)]} {
- lappend opts "$key=$value"
- }
- }
-
- set composite_version [composite_version $portversion [array get variations] 1]
- if { $composite_version ne "" } {
- set ver_field "@$composite_version"
- } else {
- set ver_field ""
- }
- puts [format "%-30s %s %s" $portname $ver_field [join $opts " "]]
- } else {
- puts "$portname"
- }
- }
-
- return 0
-}
-
-
-proc action_portcmds { action portlist opts } {
- # Operations on the port's directory and Portfile
- global env boot_env current_portdir
-
- array set local_options $opts
-
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
- foreachport $portlist {
- array unset portinfo
- # If we have a url, use that, since it's most specific, otherwise try to map the portname to a url
- if {$porturl eq ""} {
-
- # Verify the portname, getting portinfo to map to a porturl
- if {[catch {set res [mportlookup $portname]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $res] < 2} {
- break_softcontinue "Port $portname not found" 1 status
- }
- array set portinfo [lindex $res 1]
- set porturl $portinfo(porturl)
- set portname $portinfo(name)
- }
-
-
- # Calculate portdir, porturl, and portfile from initial porturl
- set portdir [file normalize [macports::getportdir $porturl]]
- set porturl "file://${portdir}"; # Rebuild url so it's fully qualified
- set portfile "${portdir}/Portfile"
-
- # Now execute the specific action
- if {[file readable $portfile]} {
- switch -- $action {
- cat {
- # Copy the portfile to standard output
- set f [open $portfile RDONLY]
- while { ![eof $f] } {
- puts -nonewline [read $f 4096]
- }
- close $f
- }
-
- edit {
- # Edit the port's portfile with the user's editor
-
- # Restore our entire environment from start time.
- # We need it to evaluate the editor, and the editor
- # may want stuff from it as well, like TERM.
- array unset env_save; array set env_save [array get env]
- array unset env *
- if {${macports::macosx_version} eq "10.5"} {
- unsetenv *
- }
- array set env [array get boot_env]
-
- # Find an editor to edit the portfile
- set editor ""
- set editor_var "ports_${action}_editor"
- if {[info exists local_options($editor_var)]} {
- set editor [join $local_options($editor_var)]
- } else {
- foreach ed { MP_EDITOR VISUAL EDITOR } {
- if {[info exists env($ed)]} {
- set editor $env($ed)
- break
- }
- }
- }
-
- # Use a reasonable canned default if no editor specified or set in env
- if { $editor eq "" } { set editor "/usr/bin/vi" }
-
- # Invoke the editor
- if {[catch {eval exec >@stdout <@stdin 2>@stderr $editor {$portfile}} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "unable to invoke editor $editor: $result" 1 status
- }
-
- # Restore internal MacPorts environment
- array unset env *
- if {${macports::macosx_version} eq "10.5"} {
- unsetenv *
- }
- array set env [array get env_save]
- }
-
- dir {
- # output the path to the port's directory
- puts $portdir
- }
-
- work {
- # output the path to the port's work directory
- set workpath [macports::getportworkpath_from_portdir $portdir $portname]
- if {[file exists $workpath]} {
- puts $workpath
- }
- }
-
- cd {
- # Change to the port's directory, making it the default
- # port for any future commands
- set current_portdir $portdir
- }
-
- url {
- # output the url of the port's directory, suitable to feed back in later as a port descriptor
- puts $porturl
- }
-
- file {
- # output the path to the port's portfile
- puts $portfile
- }
-
- logfile {
- set logfile [file join [macports::getportlogpath $portdir $portname] "main.log"]
- if {[file isfile $logfile]} {
- puts $logfile
- } else {
- ui_error "Log file not found for port in $portdir"
- }
- }
-
- gohome {
- set homepage ""
-
- # Get the homepage as read from PortIndex
- if {[info exists portinfo(homepage)]} {
- set homepage $portinfo(homepage)
- }
-
- # If not available, get the homepage for the port by opening the Portfile
- if {$homepage eq "" && ![catch {set ctx [mportopen $porturl]} result]} {
- array set portinfo [mportinfo $ctx]
- if {[info exists portinfo(homepage)]} {
- set homepage $portinfo(homepage)
- }
- mportclose $ctx
- }
-
- # Try to open a browser to the homepage for the given port
- if { $homepage ne "" } {
- if {[catch {system "${macports::autoconf::open_path} '$homepage'"} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "unable to invoke browser using ${macports::autoconf::open_path}: $result" 1 status
- }
- } else {
- ui_error [format "No homepage for %s" $portname]
- }
- }
- }
- } else {
- break_softcontinue "Could not read $portfile" 1 status
- }
- }
-
- return $status
-}
-
-
-proc action_sync { action portlist opts } {
- global global_options
-
- set status 0
- if {[catch {mportsync [array get global_options]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- ui_msg "port sync failed: $result"
- set status 1
- }
-
- return $status
-}
-
-
-proc action_target { action portlist opts } {
- global global_variations
- set status 0
- if {[require_portlist portlist]} {
- return 1
- }
- if {($action eq "install" || $action eq "archive") && [prefix_unwritable] && ![macports::global_option_isset ports_dryrun]} {
- return 1
- }
- foreachport $portlist {
- array unset portinfo
- # If we have a url, use that, since it's most specific
- # otherwise try to map the portname to a url
- if {$porturl eq ""} {
- # Verify the portname, getting portinfo to map to a porturl
- if {[catch {set res [mportlookup $portname]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "lookup of portname $portname failed: $result" 1 status
- }
- if {[llength $res] < 2} {
- # don't error for ports that are installed but not in the tree
- if {[registry::entry_exists_for_name $portname]} {
- ui_warn "Skipping $portname (not in the ports tree)"
- continue
- } else {
- break_softcontinue "Port $portname not found" 1 status
- }
- }
- array set portinfo [lindex $res 1]
- set porturl $portinfo(porturl)
- }
-
- # use existing variants iff none were explicitly requested
- if {[array get requested_variations] eq "" && [array get variations] ne ""} {
- array unset requested_variations
- array set requested_variations [array get variations]
- }
-
- # Add any global_variations to the variations
- # specified for the port
- foreach { variation value } [array get global_variations] {
- if { ![info exists requested_variations($variation)] } {
- set requested_variations($variation) $value
- }
- }
-
- # If version was specified, save it as a version glob for use
- # in port actions (e.g. clean).
- if {[string length $portversion]} {
- set options(ports_version_glob) $portversion
- }
- # if installing, mark the port as explicitly requested
- if {$action eq "install"} {
- if {![info exists options(ports_install_unrequested)]} {
- set options(ports_requested) 1
- }
- # we actually activate as well
- set target activate
- } elseif {$action eq "archive"} {
- set target install
- } else {
- set target $action
- }
- if {![info exists options(subport)]} {
- if {[info exists portinfo(name)]} {
- set options(subport) $portinfo(name)
- } else {
- set options(subport) $portname
- }
- }
- if {[catch {set workername [mportopen $porturl [array get options] [array get requested_variations]]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- break_softcontinue "Unable to open port: $result" 1 status
- }
- if {[catch {set result [mportexec $workername $target]} result]} {
- global errorInfo
- mportclose $workername
- ui_debug "$errorInfo"
- break_softcontinue "Unable to execute port: $result" 1 status
- }
-
- mportclose $workername
-
- # Process any error that wasn't thrown and handled already
- if {$result} {
- print_tickets_url
- break_softcontinue "Processing of port $portname failed" 1 status
- }
- }
-
- if {$status == 0 && $action eq "install" && ![macports::global_option_isset ports_dryrun]} {
- array set options $opts
- if {![info exists options(ports_nodeps)] && ![info exists options(ports_install_no-rev-upgrade)] && ${macports::revupgrade_autorun}} {
- set status [action_revupgrade $action $portlist $opts]
- }
- }
-
- return $status
-}
-
-
-proc action_exit { action portlist opts } {
- # Return a semaphore telling the main loop to quit
- return -999
-}
-
-
-##########################################
-# Command Parsing
-##########################################
-proc moreargs {} {
- global cmd_argn cmd_argc
- return [expr {$cmd_argn < $cmd_argc}]
-}
-
-
-proc lookahead {} {
- global cmd_argn cmd_argc cmd_argv
- if {$cmd_argn < $cmd_argc} {
- return [lindex $cmd_argv $cmd_argn]
- } else {
- return _EOF_
- }
-}
-
-
-proc advance {} {
- global cmd_argn
- incr cmd_argn
-}
-
-
-proc match s {
- if {[lookahead] == $s} {
- advance
- return 1
- }
- return 0
-}
-
-# action_array specifies which action to run on the given command
-# and if the action wants an expanded portlist.
-# The value is a list of the form {action expand},
-# where action is a string and expand a value:
-# 0 none Does not expect any text argument
-# 1 strings Expects some strings as text argument
-# 2 ports Wants an expanded list of ports as text argument
-global action_array
-
-# Define global constants
-const ACTION_ARGS_NONE 0
-const ACTION_ARGS_STRINGS 1
-const ACTION_ARGS_PORTS 2
-
-array set action_array [list \
- usage [list action_usage [ACTION_ARGS_STRINGS]] \
- help [list action_help [ACTION_ARGS_STRINGS]] \
- \
- echo [list action_echo [ACTION_ARGS_PORTS]] \
- \
- info [list action_info [ACTION_ARGS_PORTS]] \
- location [list action_location [ACTION_ARGS_PORTS]] \
- notes [list action_notes [ACTION_ARGS_PORTS]] \
- provides [list action_provides [ACTION_ARGS_STRINGS]] \
- log [list action_log [ACTION_ARGS_PORTS]] \
- \
- activate [list action_activate [ACTION_ARGS_PORTS]] \
- deactivate [list action_deactivate [ACTION_ARGS_PORTS]] \
- \
- select [list action_select [ACTION_ARGS_STRINGS]] \
- \
- sync [list action_sync [ACTION_ARGS_NONE]] \
- selfupdate [list action_selfupdate [ACTION_ARGS_NONE]] \
- \
- setrequested [list action_setrequested [ACTION_ARGS_PORTS]] \
- unsetrequested [list action_setrequested [ACTION_ARGS_PORTS]] \
- \
- upgrade [list action_upgrade [ACTION_ARGS_PORTS]] \
- rev-upgrade [list action_revupgrade [ACTION_ARGS_NONE]] \
- reclaim [list action_reclaim [ACTION_ARGS_NONE]] \
- doctor [list action_doctor [ACTION_ARGS_NONE]] \
- \
- version [list action_version [ACTION_ARGS_NONE]] \
- platform [list action_platform [ACTION_ARGS_NONE]] \
- \
- uninstall [list action_uninstall [ACTION_ARGS_PORTS]] \
- \
- installed [list action_installed [ACTION_ARGS_PORTS]] \
- outdated [list action_outdated [ACTION_ARGS_PORTS]] \
- contents [list action_contents [ACTION_ARGS_PORTS]] \
- space [list action_space [ACTION_ARGS_PORTS]] \
- dependents [list action_dependents [ACTION_ARGS_PORTS]] \
- rdependents [list action_dependents [ACTION_ARGS_PORTS]] \
- deps [list action_deps [ACTION_ARGS_PORTS]] \
- rdeps [list action_deps [ACTION_ARGS_PORTS]] \
- variants [list action_variants [ACTION_ARGS_PORTS]] \
- \
- search [list action_search [ACTION_ARGS_STRINGS]] \
- list [list action_list [ACTION_ARGS_PORTS]] \
- \
- edit [list action_portcmds [ACTION_ARGS_PORTS]] \
- cat [list action_portcmds [ACTION_ARGS_PORTS]] \
- dir [list action_portcmds [ACTION_ARGS_PORTS]] \
- work [list action_portcmds [ACTION_ARGS_PORTS]] \
- cd [list action_portcmds [ACTION_ARGS_PORTS]] \
- url [list action_portcmds [ACTION_ARGS_PORTS]] \
- file [list action_portcmds [ACTION_ARGS_PORTS]] \
- logfile [list action_portcmds [ACTION_ARGS_PORTS]] \
- gohome [list action_portcmds [ACTION_ARGS_PORTS]] \
- \
- fetch [list action_target [ACTION_ARGS_PORTS]] \
- checksum [list action_target [ACTION_ARGS_PORTS]] \
- extract [list action_target [ACTION_ARGS_PORTS]] \
- patch [list action_target [ACTION_ARGS_PORTS]] \
- configure [list action_target [ACTION_ARGS_PORTS]] \
- build [list action_target [ACTION_ARGS_PORTS]] \
- destroot [list action_target [ACTION_ARGS_PORTS]] \
- install [list action_target [ACTION_ARGS_PORTS]] \
- clean [list action_target [ACTION_ARGS_PORTS]] \
- test [list action_target [ACTION_ARGS_PORTS]] \
- lint [list action_target [ACTION_ARGS_PORTS]] \
- livecheck [list action_target [ACTION_ARGS_PORTS]] \
- distcheck [list action_target [ACTION_ARGS_PORTS]] \
- mirror [list action_target [ACTION_ARGS_PORTS]] \
- load [list action_target [ACTION_ARGS_PORTS]] \
- unload [list action_target [ACTION_ARGS_PORTS]] \
- distfiles [list action_target [ACTION_ARGS_PORTS]] \
- \
- archivefetch [list action_target [ACTION_ARGS_PORTS]] \
- archive [list action_target [ACTION_ARGS_PORTS]] \
- unarchive [list action_target [ACTION_ARGS_PORTS]] \
- dmg [list action_target [ACTION_ARGS_PORTS]] \
- mdmg [list action_target [ACTION_ARGS_PORTS]] \
- dpkg [list action_target [ACTION_ARGS_PORTS]] \
- mpkg [list action_target [ACTION_ARGS_PORTS]] \
- pkg [list action_target [ACTION_ARGS_PORTS]] \
- portpkg [list action_target [ACTION_ARGS_PORTS]] \
- rpm [list action_target [ACTION_ARGS_PORTS]] \
- srpm [list action_target [ACTION_ARGS_PORTS]] \
- \
- quit [list action_exit [ACTION_ARGS_NONE]] \
- exit [list action_exit [ACTION_ARGS_NONE]] \
-]
-
-# Expand "action".
-# Returns an action proc, or a list of matching action procs, or the action passed in
-proc find_action { action } {
- global action_array
-
- if { ! [info exists action_array($action)] } {
- set guess [guess_action $action]
- if { [info exists action_array($guess)] } {
- return $guess
- }
- return $guess
- }
-
- return $action
-}
-
-# Expand action
-# If there's more than one match, return the next possibility
-proc find_action_proc { action } {
- global action_array
-
- set action_proc ""
- if { [info exists action_array($action)] } {
- set action_proc [lindex $action_array($action) 0]
- } else {
- set action [complete_action $action]
- if { [info exists action_array($action)] } {
- set action_proc [lindex $action_array($action) 0]
- }
- }
-
- return $action_proc
-}
-
-proc get_action_proc { action } {
- global action_array
-
- set action_proc ""
- if { [info exists action_array($action)] } {
- set action_proc [lindex $action_array($action) 0]
- }
-
- return $action_proc
-}
-
-# Returns whether an action expects text arguments at all,
-# expects text arguments or wants an expanded list of ports
-# Return values are constants:
-# [ACTION_ARGS_NONE] Does not expect any text argument
-# [ACTION_ARGS_STRINGS] Expects some strings as text argument
-# [ACTION_ARGS_PORTS] Wants an expanded list of ports as text argument
-proc action_needs_portlist { action } {
- global action_array
-
- set ret 0
- if {[info exists action_array($action)]} {
- set ret [lindex $action_array($action) 1]
- }
-
- return $ret
-}
-
-# cmd_opts_array specifies which arguments the commands accept
-# Commands not listed here do not accept any arguments
-# Syntax if {option argn}
-# Where option is the name of the option and argn specifies how many arguments
-# this argument takes
-global cmd_opts_array
-array set cmd_opts_array {
- edit {{editor 1}}
- info {category categories depends_fetch depends_extract
- depends_build depends_lib depends_run
- depends description epoch fullname heading homepage index license
- line long_description
- maintainer maintainers name platform platforms portdir pretty
- replaced_by revision subports variant variants version}
- contents {size {units 1}}
- deps {index no-build}
- rdeps {index no-build full}
- rdependents {full}
- search {case-sensitive category categories depends_fetch
- depends_extract depends_build depends_lib depends_run
- depends description epoch exact glob homepage line
- long_description maintainer maintainers name platform
- platforms portdir regex revision variant variants version}
- selfupdate {nosync}
- space {{units 1} total}
- activate {no-exec}
- deactivate {no-exec}
- install {no-rev-upgrade unrequested}
- uninstall {follow-dependents follow-dependencies no-exec}
- variants {index}
- clean {all archive dist work logs}
- mirror {new}
- lint {nitpick}
- select {list set show summary}
- log {{phase 1} {level 1}}
- upgrade {force enforce-variants no-replace no-rev-upgrade}
- rev-upgrade {id-loadcmd-check}
- doctor {quiet}
-}
-
-##
-# Checks whether the given option is valid
-#
-# @param action for which action
-# @param option the prefix of the option to check
-# @return list of pairs {name argc} for all matching options
-proc cmd_option_matches {action option} {
- global cmd_opts_array
-
- # This could be so easy with lsearch -index,
- # but that's only available as of Tcl 8.5
-
- if {![info exists cmd_opts_array($action)]} {
- return {}
- }
-
- set result {}
-
- foreach item $cmd_opts_array($action) {
- if {[llength $item] == 1} {
- set name $item
- set argc 0
- } else {
- set name [lindex $item 0]
- set argc [lindex $item 1]
- }
-
- if {$name == $option} {
- set result [list [list $name $argc]]
- break
- } elseif {[string first $option $name] == 0} {
- lappend result [list $name $argc]
- }
- }
-
- return $result
-}
-
-# Parse global options
-#
-# Note that this is called several times:
-# (1) Initially, to parse options that will be constant across all commands
-# (options that come prior to any command, frozen into global_options_base)
-# (2) Following each command (to parse options that will be unique to that command
-# (the global_options array is reset to global_options_base prior to each command)
-#
-proc parse_options { action ui_options_name global_options_name } {
- upvar $ui_options_name ui_options
- upvar $global_options_name global_options
- global cmdname cmd_opts_array
-
- while {[moreargs]} {
- set arg [lookahead]
-
- if {[string index $arg 0] ne "-"} {
- break
- } elseif {[string index $arg 1] eq "-"} {
- # Process long arguments
- switch -- $arg {
- -- { # This is the options terminator; do no further option processing
- advance; break
- }
- default {
- set key [string range $arg 2 end]
- set kopts [cmd_option_matches $action $key]
- if {[llength $kopts] == 0} {
- return -code error "${action} does not accept --${key}"
- } elseif {[llength $kopts] > 1} {
- set errlst {}
- foreach e $kopts {
- lappend errlst "--[lindex $e 0]"
- }
- return -code error "\"port ${action} --${key}\" is ambiguous: \n port ${action} [join $errlst "\n port ${action} "]"
- }
- set key [lindex $kopts 0 0]
- set kargc [lindex $kopts 0 1]
- if {$kargc == 0} {
- set global_options(ports_${action}_${key}) yes
- } else {
- set args {}
- while {[moreargs] && $kargc > 0} {
- advance
- lappend args [lookahead]
- set kargc [expr {$kargc - 1}]
- }
- if {$kargc > 0} {
- return -code error "--${key} expects [expr {$kargc + [llength $args]}] parameters!"
- }
- set global_options(ports_${action}_${key}) $args
- }
- }
- }
- } else {
- # Process short arg(s)
- set opts [string range $arg 1 end]
- foreach c [split $opts {}] {
- switch -- $c {
- v {
- set ui_options(ports_verbose) yes
- }
- d {
- set ui_options(ports_debug) yes
- # debug implies verbose
- set ui_options(ports_verbose) yes
- }
- q {
- set ui_options(ports_quiet) yes
- }
- p {
- # Ignore errors while processing within a command
- set ui_options(ports_processall) yes
- }
- f {
- set global_options(ports_force) yes
- }
- o {
- set global_options(ports_ignore_different) yes
- }
- n {
- set global_options(ports_nodeps) yes
- }
- u {
- set global_options(port_uninstall_old) yes
- }
- R {
- set global_options(ports_do_dependents) yes
- }
- s {
- set global_options(ports_source_only) yes
- }
- b {
- set global_options(ports_binary_only) yes
- }
- c {
- set global_options(ports_autoclean) yes
- }
- k {
- set global_options(ports_autoclean) no
- }
- t {
- set global_options(ports_trace) yes
- }
- y {
- set global_options(ports_dryrun) yes
- }
- F {
- # Name a command file to process
- advance
- if {[moreargs]} {
- lappend ui_options(ports_commandfiles) [lookahead]
- }
- }
- D {
- advance
- if {[moreargs]} {
- cd [lookahead]
- }
- break
- }
- default {
- print_usage; exit 1
- }
- }
- }
- }
-
- advance
- }
-}
-
-# acquire exclusive registry lock for actions that need it
-# returns 1 if locked, 0 otherwise
-proc lock_reg_if_needed {action} {
- switch -- $action {
- activate -
- deactivate -
- setrequested -
- unsetrequested -
- upgrade -
- uninstall -
- install {
- registry::exclusive_lock
- return 1
- }
- }
- return 0
-}
-
-proc process_cmd { argv } {
- global cmd_argc cmd_argv cmd_argn \
- global_options global_options_base private_options ui_options \
- current_portdir
- set cmd_argv $argv
- set cmd_argc [llength $argv]
- set cmd_argn 0
-
- set action_status 0
-
- # Process an action if there is one
- while {($action_status == 0 || [macports::ui_isset ports_processall]) && [moreargs]} {
- set action [lookahead]
- advance
-
- # Handle command separator
- if { $action == ";" } {
- continue
- }
-
- # Handle a comment
- if { [string index $action 0] == "#" } {
- while { [moreargs] } { advance }
- break
- }
-
- set locked [lock_reg_if_needed $action]
- # Always start out processing an action in current_portdir
- cd $current_portdir
-
- # Reset global_options from base before each action, as we munge it just below...
- array unset global_options
- array set global_options $global_options_base
-
- # Find an action to execute
- set actions [find_action $action]
- if {[llength $actions] == 1} {
- set action [lindex $actions 0]
- set action_proc [get_action_proc $action]
- } else {
- if {[llength $actions] > 1} {
- ui_error "\"port ${action}\" is ambiguous: \n port [join $actions "\n port "]"
- } else {
- ui_error "Unrecognized action \"port $action\""
- }
- set action_status 1
- break
- }
-
- # Parse options that will be unique to this action
- # (to avoid abiguity with -variants and a default port, either -- must be
- # used to terminate option processing, or the pseudo-port current must be specified).
- if {[catch {parse_options $action ui_options global_options} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- ui_error $result
- set action_status 1
- break
- }
-
- # What kind of arguments does the command expect?
- set expand [action_needs_portlist $action]
-
- # Parse action arguments, setting a special flag if there were none
- # We otherwise can't tell the difference between arguments that evaluate
- # to the empty set, and the empty set itself.
- set portlist {}
- switch -- [lookahead] {
- ; -
- _EOF_ {
- set private_options(ports_no_args) yes
- }
- default {
- if {[ACTION_ARGS_NONE] == $expand} {
- ui_error "$action does not accept string arguments"
- set action_status 1
- break
- } elseif {[ACTION_ARGS_STRINGS] == $expand} {
- while { [moreargs] && ![match ";"] } {
- lappend portlist [lookahead]
- advance
- }
- } elseif {[ACTION_ARGS_PORTS] == $expand} {
- # Parse port specifications into portlist
- if {![portExpr portlist]} {
- ui_error "Improper expression syntax while processing parameters"
- set action_status 1
- break
- }
- }
- }
- }
-
- # execute the action
- set action_status [$action_proc $action $portlist [array get global_options]]
-
- # unlock if needed
- if {$locked} {
- registry::exclusive_unlock
- }
-
- # Print notifications of just-activated ports.
- portclient::notifications::display
-
- # semaphore to exit
- if {$action_status == -999} break
- }
-
- return $action_status
-}
-
-
-proc complete_portname { text state } {
- global complete_choices complete_position
-
- if {$state == 0} {
- set complete_position 0
- set complete_choices {}
-
- # Build a list of ports with text as their prefix
- if {[catch {set res [mportsearch "${text}*" false glob]} result]} {
- global errorInfo
- ui_debug "$errorInfo"
- fatal "search for portname $pattern failed: $result"
- }
- foreach {name info} $res {
- lappend complete_choices $name
- }
- }
-
- set word [lindex $complete_choices $complete_position]
- incr complete_position
-
- return $word
-}
-
-
-# return text action beginning with $text
-proc complete_action { text state } {
- global action_array complete_choices complete_position
-
- if {$state == 0} {
- set complete_position 0
- set complete_choices [array names action_array "[string tolower $text]*"]
- }
-
- set word [lindex $complete_choices $complete_position]
- incr complete_position
-
- return $word
-}
-
-# return all actions beginning with $text
-proc guess_action { text } {
- global action_array
-
- return [array names action_array "[string tolower $text]*"]
-
- if { [llength $complete_choices ] == 1 } {
- return [lindex $complete_choices 0]
- }
-
- return {}
-}
-
-proc attempt_completion { text word start end } {
- # If the word starts with '~', or contains '.' or '/', then use the build-in
- # completion to complete the word
- if { [regexp {^~|[/.]} $word] } {
- return ""
- }
-
- # Decide how to do completion based on where we are in the string
- set prefix [string range $text 0 [expr {$start - 1}]]
-
- # If only whitespace characters preceed us, or if the
- # previous non-whitespace character was a ;, then we're
- # an action (the first word of a command)
- if { [regexp {(^\s*$)|(;\s*$)} $prefix] } {
- return complete_action
- }
-
- # Otherwise, do completion on portname
- return complete_portname
-}
-
-
-proc get_next_cmdline { in out use_readline prompt linename } {
- upvar $linename line
-
- set line ""
- while { $line eq "" } {
-
- if {$use_readline} {
- set len [readline read -attempted_completion attempt_completion line $prompt]
- } else {
- puts -nonewline $out $prompt
- flush $out
- set len [gets $in line]
- }
-
- if { $len < 0 } {
- return -1
- }
-
- set line [string trim $line]
-
- if { $use_readline && $line ne "" } {
- rl_history add $line
- }
- }
-
- return [llength $line]
-}
-
-
-proc process_command_file { in } {
- global current_portdir
-
- # Initialize readline
- set isstdin [string match $in "stdin"]
- set name "port"
- set use_readline [expr {$isstdin && [readline init $name]}]
- set history_file [file normalize "${macports::macports_user_dir}/history"]
-
- # Read readline history
- if {$use_readline && [file isdirectory $macports::macports_user_dir]} {
- rl_history read $history_file
- rl_history stifle 100
- }
-
- # Be noisy, if appropriate
- set noisy [expr $isstdin && ![macports::ui_isset ports_quiet]]
- if { $noisy } {
- puts "MacPorts [macports::version]"
- puts "Entering interactive mode... (\"help\" for help, \"quit\" to quit)"
- }
-
- # Main command loop
- set exit_status 0
- while { $exit_status == 0 || $isstdin || [macports::ui_isset ports_processall] } {
-
- # Calculate our prompt
- if { $noisy } {
- set shortdir [eval file join [lrange [file split $current_portdir] end-1 end]]
- set prompt "\[$shortdir\] > "
- } else {
- set prompt ""
- }
-
- # Get a command line
- if { [get_next_cmdline $in stdout $use_readline $prompt line] <= 0 } {
- puts ""
- break
- }
-
- # Process the command
- set exit_status [process_cmd $line]
-
- # Check for semaphore to exit
- if {$exit_status == -999} {
- set exit_status 0
- break
- }
- }
-
- # Create macports user directory if it does not exist yet
- if {$use_readline && ![file isdirectory $macports::macports_user_dir]} {
- file mkdir $macports::macports_user_dir
- }
- # Save readine history
- if {$use_readline && [file isdirectory $macports::macports_user_dir]} {
- rl_history write $history_file
- }
-
- # Say goodbye
- if { $noisy } {
- puts "Goodbye"
- }
-
- return $exit_status
-}
-
-
-proc process_command_files { filelist } {
- set exit_status 0
-
- # For each file in the command list, process commands
- # in the file
- foreach file $filelist {
- if {$file eq "-"} {
- set in stdin
- } else {
- if {[catch {set in [open $file]} result]} {
- fatal "Failed to open command file; $result"
- }
- }
-
- set exit_status [process_command_file $in]
-
- if {$in ne "stdin"} {
- close $in
- }
-
- # Exit on first failure unless -p was given
- if {$exit_status != 0 && ![macports::ui_isset ports_processall]} {
- return $exit_status
- }
- }
-
- return $exit_status
-}
-
-namespace eval portclient::progress {
- ##
- # Maximum width of the progress bar or indicator when displaying it.
- variable maxWidth 50
-
- ##
- # The start time of the last progress callback as returned by [clock time].
- # Since only one progress indicator is active at a time, this variable is
- # shared between the different variants of progress functions.
- variable startTime
-
- ##
- # Delay in milliseconds after the start of the operation before deciding
- # that showing a progress bar makes sense.
- variable showTimeThreshold 500
-
- ##
- # Percentage value between 0 and 1 that must not have been reached yet when
- # $showTimeThreshold has passed for a progress bar to be shown. If the
- # operation has proceeded above e.g. 75% after 500ms we won't bother
- # displaying a progress indicator anymore -- the operation will be finished
- # in well below a second anyway.
- variable showPercentageThreshold 0.75
-
- ##
- # Boolean indication whether the progress indicator should be shown or is
- # still hidden because the current operation didn't need enough time for
- # a progress indicator to make sense, yet.
- variable show no
-
- ##
- # Initialize the progress bar display delay; call this from the start
- # action of the progress functions.
- proc initDelay {} {
- variable show
- variable startTime
-
- set startTime [clock milliseconds]
- set show no
- }
-
- ##
- # Determine whether a progress bar should be shown for the current
- # operation in its current state. You must have called initDelay for the
- # current operation before calling this method.
- #
- # @param cur
- # Current progress in abstract units.
- # @param total
- # Total number of abstract units to be processed, if known. Pass
- # 0 if unknown.
- # @return
- # "yes", if the progress indicator should be shown, "no" otherwise.
- proc showProgress {cur total} {
- variable show
- variable startTime
- variable showTimeThreshold
- variable showPercentageThreshold
-
- if {$show eq "yes"} {
- return yes
- } else {
- if {[expr {[clock milliseconds] - $startTime}] > $showTimeThreshold &&
- ($total == 0 || [expr {double($cur) / double($total)}] < $showPercentageThreshold)} {
- set show yes
- }
- return $show
- }
- }
-
- ##
- # Progress callback for generic operations executed by macports 1.0.
- #
- # @param action
- # One of "start", "update", "intermission" or "finish", where start
- # will be called before any number of update calls, interrupted by
- # any number of intermission calls (called because other output is
- # being produced), followed by one call to finish.
- # @param args
- # A list of variadic args that differ for each action. For "start",
- # "intermission" and "finish", the args are empty and unused. For
- # "update", args contains $cur and $total, where $cur is the current
- # number of units processed and $total is the total number of units
- # to be processed. If the total is not known, it is 0.
- proc generic {action args} {
- global env
- variable maxWidth
-
- switch -nocase -- $action {
- start {
- initDelay
- }
- update {
- # the for loop is a simple hack because Tcl 8.4 doesn't have
- # lassign
- foreach {now total} $args {
- if {[showProgress $now $total] eq "yes"} {
- set barPrefix " "
- set barPrefixLen [string length $barPrefix]
- if {$total != 0} {
- progressbar $now $total [expr {min($maxWidth, $env(COLUMNS) - $barPrefixLen)}] $barPrefix
- } else {
- unprogressbar [expr {min($maxWidth, $env(COLUMNS) - $barPrefixLen)}] $barPrefix
- }
- }
- }
- }
- intermission -
- finish {
- # erase to start of line
- ::term::ansi::send::esol
- # return cursor to start of line
- puts -nonewline "\r"
- flush stdout
- }
- }
-
- return 0
- }
-
- ##
- # Progress callback for downloads executed by macports 1.0.
- #
- # This is essentially a cURL progress callback.
- #
- # @param action
- # One of "start", "update" or "finish", where start will be called
- # before any number of update calls, followed by one call to finish.
- # @param args
- # A list of variadic args that differ for each action. For "start",
- # contains a single argument "ul" or "dl" indicating whether this is
- # an up- or download. For "update", contains the arguments
- # ("ul"|"dl") $total $now $speed where ul/dl are as for start, and
- # total, now and speed are doubles indicating the total transfer
- # size, currently transferred amount and average speed per second in
- # bytes. Unused for "finish".
- proc download {action args} {
- global env
- variable maxWidth
-
- switch -nocase -- $action {
- start {
- initDelay
- }
- update {
- # the for loop is a simple hack because Tcl 8.4 doesn't have
- # lassign
- foreach {type total now speed} $args {
- if {[showProgress $now $total] eq "yes"} {
- set barPrefix " "
- set barPrefixLen [string length $barPrefix]
- if {$total != 0} {
- set barSuffix [format " speed: %-13s" "[bytesize $speed {} "%.1f"]/s"]
- set barSuffixLen [string length $barSuffix]
-
- set barLen [expr {min($maxWidth, $env(COLUMNS) - $barPrefixLen - $barSuffixLen)}]
- progressbar $now $total $barLen $barPrefix $barSuffix
- } else {
- set barSuffix [format " %-10s speed: %-13s" [bytesize $now {} "%6.1f"] "[bytesize $speed {} "%.1f"]/s"]
- set barSuffixLen [string length $barSuffix]
-
- set barLen [expr {min($maxWidth, $env(COLUMNS) - $barPrefixLen - $barSuffixLen)}]
- unprogressbar $barLen $barPrefix $barSuffix
- }
- }
- }
- }
- finish {
- # erase to start of line
- ::term::ansi::send::esol
- # return cursor to start of line
- puts -nonewline "\r"
- flush stdout
- }
- }
-
- return 0
- }
-
- ##
- # Draw a progress bar using unicode block drawing characters
- #
- # @param current
- # The current progress value.
- # @param total
- # The progress value representing 100%.
- # @param width
- # The width in characters of the progress bar. This includes percentage
- # output, which takes up 8 characters.
- # @param prefix
- # Prefix to be printed in front of the progress bar.
- # @param suffix
- # Suffix to be printed after the progress bar.
- proc progressbar {current total width {prefix ""} {suffix ""}} {
- # Subtract the width of the percentage output, also subtract the two
- # characters [ and ] bounding the progress bar.
- set percentageWidth 8
- set barWidth [expr {entier($width) - $percentageWidth - 2}]
-
- # Map the range (0, $total) to (0, 4 * $width) where $width is the maximum
- # numebr of characters to be printed for the progress bar. Multiply the
- # upper bound with 8 because we have 8 sub-states per character.
- set barProgress [expr {entier(round(($current * $barWidth * 8) / $total))}]
-
- set barInteger [expr {$barProgress / 8}]
- #set barRemainder [expr {$barProgress % 8}]
-
- # Finally, also provide a percentage value to print behind the progress bar
- set percentage [expr {double($current) * 100 / double($total)}]
-
- # clear the current line, enable reverse video
- set progressbar "\033\[7m"
- for {set i 0} {$i < $barInteger} {incr i} {
- # U+2588 FULL BLOCK doesn't match the other blocks in some fonts :/
- # Two half blocks work better in some fonts, but not in others (because
- # they leave ugly spaces). So, one or the other choice isn't better or
- # worse and even just using full blocks looks ugly in a few fonts.
-
- # Use pure ASCII until somebody fixes most of the default terminal fonts :/
- append progressbar " "
- }
- # back to normal output
- append progressbar "\033\[0m"
-
- #switch $barRemainder {
- # 0 {
- # if {$barInteger < $barWidth} {
- # append progressbar " "
- # }
- # }
- # 1 {
- # # U+258F LEFT ONE EIGHTH BLOCK
- # append progressbar "\u258f"
- # }
- # 2 {
- # # U+258E LEFT ONE QUARTER BLOCK
- # append progressbar "\u258e"
- # }
- # 3 {
- # # U+258D LEFT THREE EIGHTHS BLOCK
- # append progressbar "\u258d"
- # }
- # 3 {
- # # U+258D LEFT THREE EIGHTHS BLOCK
- # append progressbar "\u258d"
- # }
- # 4 {
- # # U+258C LEFT HALF BLOCK
- # append progressbar "\u258c"
- # }
- # 5 {
- # # U+258B LEFT FIVE EIGHTHS BLOCK
- # append progressbar "\u258b"
- # }
- # 6 {
- # # U+258A LEFT THREE QUARTERS BLOCK
- # append progressbar "\u258a"
- # }
- # 7 {
- # # U+2589 LEFT SEVEN EIGHTHS BLOCK
- # append progressbar "\u2589"
- # }
- #}
-
- # Fill the progress bar with spaces
- for {set i $barInteger} {$i < $barWidth} {incr i} {
- append progressbar " "
- }
-
- # Format the percentage using the space that has been reserved for it
- set percentagesuffix [format " %[expr {$percentageWidth - 3}].1f %%" $percentage]
-
- puts -nonewline "\r${prefix}\[${progressbar}\]${percentagesuffix}${suffix}"
- flush stdout
- }
-
-
- ##
- # Internal state of the progress indicator; unless you're hacking the
- # unprogressbar code you should never touch this.
- variable unprogressState 0
-
- ##
- # Draw a progress indicator
- #
- # @param width
- # The width in characters of the progress indicator.
- # @param prefix
- # Prefix to be printed in front of the progress indicator.
- # @param suffix
- # Suffix to be printed after the progress indicator.
- proc unprogressbar {width {prefix ""} {suffix ""}} {
- variable unprogressState
-
- # Subtract the two characters [ and ] bounding the progress indicator
- # from the width.
- set barWidth [expr {int($width) - 2}]
-
- # Number of states of the progress bar, or rather: the number of
- # characters before the sequence repeats.
- set numStates 4
-
- set unprogressState [expr {($unprogressState + 1) % $numStates}]
-
- set progressbar ""
- for {set i 0} {$i < $barWidth} {incr i} {
- if {[expr {$i % $numStates}] == $unprogressState} {
- # U+2022 BULLET
- append progressbar "\u2022"
- } else {
- append progressbar " "
- }
- }
-
- puts -nonewline "\r${prefix}\[${progressbar}\]${suffix}"
- flush stdout
- }
-}
-
-namespace eval portclient::notifications {
- ##
- # Ports whose notifications to display; these were either installed
- # or requested to be installed.
- variable notificationsToPrint
- array set notificationsToPrint {}
-
- ##
- # Add a port to the list for printing notifications.
- #
- # @param name
- # The name of the port.
- # @param note
- # A list of notes to be stored for the given port.
- proc append {name notes} {
- variable notificationsToPrint
-
- set notificationsToPrint($name) $notes
- }
-
- ##
- # Print port notifications.
- #
- proc display {} {
- global env
- variable notificationsToPrint
-
- # Display notes at the end of the activation phase.
- if {[array size notificationsToPrint] > 0} {
- ui_notice "---> Some of the ports you installed have notes:"
- foreach {name notes} [array get notificationsToPrint] {
- ui_notice " $name has the following notes:"
-
- # If env(COLUMNS) exists, limit each line's width to this width.
- if {[info exists env(COLUMNS)]} {
- set maxlen $env(COLUMNS)
-
- foreach note $notes {
- foreach line [split $note "\n"] {
- set joiner ""
- set lines ""
- set newline " "
-
- foreach word [split $line " "] {
- if {[string length $newline] + [string length $word] >= $maxlen} {
- lappend lines $newline
- set newline " "
- set joiner ""
- }
- ::append newline $joiner $word
- set joiner " "
- }
- if {$newline ne {}} {
- lappend lines $newline
- }
- ui_notice [join $lines "\n"]
- }
- }
- } else {
- foreach note $notes {
- ui_notice $note
- }
- }
- }
- }
- }
-}
-
-
-##########################################
-# Main
-##########################################
-
-# Global arrays passed to the macports1.0 layer
-array set ui_options {}
-array set global_options {}
-array set global_variations {}
-
-# Global options private to this script
-array set private_options {}
-
-# Make sure we get the size of the terminal
-# We do this here to save it in the boot_env, in case we determined it manually
-term_init_size
-
-global env boot_env argv0 cmdname argc argv cmd_argc cmd_argv cmd_argn \
- current_portdir global_options_base exit_status
-
-# Save off a copy of the environment before mportinit monkeys with it
-array set boot_env [array get env]
-
-set cmdname [file tail $argv0]
-
-# Setp cmd_argv to match argv
-set cmd_argv $argv
-set cmd_argc $argc
-set cmd_argn 0
-
-# make sure we're using a sane umask
-umask 022
-
-# If we've been invoked as portf, then the first argument is assumed
-# to be the name of a command file (i.e., there is an implicit -F
-# before any arguments).
-if {[moreargs] && $cmdname eq "portf"} {
- lappend ui_options(ports_commandfiles) [lookahead]
- advance
-}
-
-# Parse global options that will affect all subsequent commands
-if {[catch {parse_options "global" ui_options global_options} result]} {
- puts "Error: $result"
- print_usage
- exit 1
-}
-
-if {[isatty stdout]
- && $portclient::progress::hasTermAnsiSend eq "yes"
- && (![info exists ui_options(ports_quiet)] || $ui_options(ports_quiet) ne "yes")} {
- set ui_options(progress_download) portclient::progress::download
- set ui_options(progress_generic) portclient::progress::generic
-}
-
-set ui_options(notifications_append) portclient::notifications::append
-
-# Get arguments remaining after option processing
-set remaining_args [lrange $cmd_argv $cmd_argn end]
-
-# If we have no arguments remaining after option processing then force
-# interactive mode
-if { [llength $remaining_args] == 0 && ![info exists ui_options(ports_commandfiles)] } {
- lappend ui_options(ports_commandfiles) -
-} elseif {[lookahead] eq "selfupdate" || [lookahead] eq "sync"} {
- # tell mportinit not to tell the user they should selfupdate
- set ui_options(ports_no_old_index_warning) 1
-}
-
-# Initialize mport
-# This must be done following parse of global options, as some options are
-# evaluated by mportinit.
-if {[catch {mportinit ui_options global_options global_variations} result]} {
- global errorInfo
- puts "$errorInfo"
- fatal "Failed to initialize MacPorts, $result"
-}
-
-# Set up some global state for our code
-set current_portdir [pwd]
-
-# Freeze global_options into global_options_base; global_options
-# will be reset to global_options_base prior to processing each command.
-set global_options_base [array get global_options]
-
-# First process any remaining args as action(s)
-set exit_status 0
-if { [llength $remaining_args] > 0 } {
-
- # If there are remaining arguments, process those as a command
- set exit_status [process_cmd $remaining_args]
-}
-
-# Process any prescribed command files, including standard input
-if { ($exit_status == 0 || [macports::ui_isset ports_processall]) && [info exists ui_options(ports_commandfiles)] } {
- set exit_status [process_command_files $ui_options(ports_commandfiles)]
-}
-if {$exit_status == -999} {
- set exit_status 0
-}
-
-# shut down macports1.0
-mportshutdown
-
-# Return with exit_status
-exit $exit_status
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://lists.macosforge.org/pipermail/macports-changes/attachments/20140813/03bb78ad/attachment-0001.html>
More information about the macports-changes
mailing list