source: trunk/base/src/port/port.tcl @ 133631

Last change on this file since 133631 was 133631, checked in by raimue@…, 5 years ago

base: expose already implemented 'port info --conflicts' to command line interface

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 189.6 KB
Line 
1#!@TCLSH@
2# -*- 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
3# $Id: port.tcl 133631 2015-03-07 15:10:00Z raimue@macports.org $
4#
5# Copyright (c) 2004-2013 The MacPorts Project
6# Copyright (c) 2004 Robert Shaw <rshaw@opendarwin.org>
7# Copyright (c) 2002-2003 Apple Inc.
8# All rights reserved.
9#
10# Redistribution and use in source and binary forms, with or without
11# modification, are permitted provided that the following conditions
12# are met:
13# 1. Redistributions of source code must retain the above copyright
14#    notice, this list of conditions and the following disclaimer.
15# 2. Redistributions in binary form must reproduce the above copyright
16#    notice, this list of conditions and the following disclaimer in the
17#    documentation and/or other materials provided with the distribution.
18# 3. Neither the name of Apple Inc. nor the names of its contributors
19#    may be used to endorse or promote products derived from this software
20#    without specific prior written permission.
21#
22# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
23# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
24# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
25# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
26# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
27# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
28# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
29# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
30# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
31# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
32# POSSIBILITY OF SUCH DAMAGE.
33
34# Create a namespace for some local variables
35namespace eval portclient::progress {
36    ##
37    # Indicate whether the term::ansi::send tcllib package is available and was
38    # imported. "yes", if the package is available, "no" otherwise.
39    variable hasTermAnsiSend no
40}
41
42if {![catch {package require term::ansi::send}]} {
43    set portclient::progress::hasTermAnsiSend yes
44}
45
46package require Tclx
47package require macports
48package require Pextlib 1.0
49
50# Standard procedures
51proc print_usage {{verbose 1}} {
52    global cmdname
53    set syntax {
54        [-bcdfknopqRstuvy] [-D portdir] [-F cmdfile] action [privopts] [actionflags]
55        [[portname|pseudo-portname|port-url] [@version] [+-variant]... [option=value]...]...
56    }
57
58    if {$verbose} {
59        puts stderr "Usage: $cmdname$syntax"
60        puts stderr "\"$cmdname help\" or \"man 1 port\" for more information."
61    } else {
62        puts stderr "$cmdname$syntax"
63    }
64}
65
66proc print_help {args} {
67    global action_array
68
69    print_usage 0
70
71    # Generate and format the command list from the action_array
72    set cmds ""
73    set lineLen 0
74    foreach cmd [lsort [array names action_array]] {
75        if {$lineLen > 65} {
76            set cmds "$cmds,\n"
77            set lineLen 0
78        }
79        if {$lineLen == 0} {
80            set new "$cmd"
81        } else {
82            set new ", $cmd"
83        }
84        incr lineLen [string length $new]
85        set cmds "$cmds$new"
86    }
87
88    set cmdText "Supported actions
89------------------
90$cmds
91"
92
93    set text {
94Pseudo-portnames
95----------------
96Pseudo-portnames are words that may be used in place of a portname, and
97which expand to some set of ports. The common pseudo-portnames are:
98all, current, active, inactive, actinact, installed, uninstalled, outdated,
99obsolete, requested, unrequested and leaves.
100These pseudo-portnames expand to the set of ports named.
101
102Pseudo-portnames starting with variants:, variant:, description:, depends:,
103depends_lib:, depends_run:, depends_build:, depends_fetch:, depends_extract:,
104portdir:, homepage:, epoch:, platforms:, platform:, name:, long_description:,
105maintainers:, maintainer:, categories:, category:, version:, revision:, and
106license: each select a set of ports based on a regex search of metadata
107about the ports. In all such cases, a standard regex pattern following
108the colon will be used to select the set of ports to which the
109pseudo-portname expands.
110
111Pseudo-portnames starting with depof:, rdepof:, dependentof:, and rdependentof:
112select ports that are direct or recursive dependencies or dependents of the
113following portname, respectively.
114
115Portnames that contain standard glob characters will be expanded to the
116set of ports matching the glob pattern.
117   
118Port expressions
119----------------
120Portnames, port glob patterns, and pseudo-portnames may be logically
121combined using expressions consisting of and, or, not, !, (, and ).
122   
123For more information
124--------------------
125See man pages: port(1), macports.conf(5), portfile(7), portgroup(7),
126porthier(7), portstyle(7). Also, see http://www.macports.org.
127    }
128
129    puts "$cmdText$text"
130}
131
132
133# Produce error message and exit
134proc fatal s {
135    global argv0
136    ui_error "$argv0: $s"
137    exit 1
138}
139
140##
141# Helper function to define constants
142#
143# Constants defined with const can simply be accessed in the same way as
144# calling a proc.
145#
146# Example:
147# const FOO 42
148# puts [FOO]
149#
150# @param name variable name
151# @param value constant variable value
152proc const {name args} {
153    proc $name {} [list return [expr $args]]
154}
155
156# Format an integer representing bytes using given units
157proc bytesize {siz {unit {}} {format {%.3f}}} {
158    if {$unit == {}} {
159        if {$siz > 0x40000000} {
160            set unit "GiB"
161        } elseif {$siz > 0x100000} {
162            set unit "MiB"
163        } elseif {$siz > 0x400} {
164            set unit "KiB"
165        } else {
166            set unit "B"
167        }
168    }
169    switch -- $unit {
170        KiB {
171            set siz [expr {$siz / 1024.0}]
172        }
173        kB {
174            set siz [expr {$siz / 1000.0}]
175        }
176        MiB {
177            set siz [expr {$siz / 1048576.0}]
178        }
179        MB {
180            set siz [expr {$siz / 1000000.0}]
181        }
182        GiB {
183            set siz [expr {$siz / 1073741824.0}]
184        }
185        GB {
186            set siz [expr {$siz / 1000000000.0}]
187        }
188        B { }
189        default {
190            ui_warn "Unknown file size unit '$unit' specified"
191            set unit "B"
192        }
193    }
194    if {[expr {round($siz)}] != $siz} {
195        set siz [format $format $siz]
196    }
197    return "$siz $unit"
198}
199
200proc filesize {fil {unit {}}} {
201    set siz {@}
202    catch {
203        set siz [bytesize [file size $fil] $unit]
204    }
205    return $siz
206}
207
208# Produce an error message, and exit, unless
209# we're handling errors in a soft fashion, in which
210# case we continue
211proc fatal_softcontinue s {
212    if {[macports::global_option_isset ports_force]} {
213        ui_error $s
214        return -code continue
215    } else {
216        fatal $s
217    }
218}
219
220
221# Produce an error message, and break, unless
222# we're handling errors in a soft fashion, in which
223# case we continue
224proc break_softcontinue { msg status name_status } {
225    upvar $name_status status_var
226    ui_error $msg
227    if {[macports::ui_isset ports_processall]} {
228        set status_var 0
229        return -code continue
230    } else {
231        set status_var $status
232        return -code break
233    }
234}
235
236# show the URL for the ticket reporting instructions
237proc print_tickets_url {args} {
238    if {${macports::prefix} ne "/usr/local" && ${macports::prefix} ne "/usr"} {
239        ui_error "Follow http://guide.macports.org/#project.tickets to report a bug."
240    }
241}
242
243# Form a composite version as is sometimes used for registry functions
244# This function sorts the variants and presents them in a canonical representation
245proc composite_version {version variations {emptyVersionOkay 0}} {
246    # Form a composite version out of the version and variations
247   
248    # Select the variations into positive and negative
249    set pos {}
250    set neg {}
251    foreach { key val } $variations {
252        if {$val eq "+"} {
253            lappend pos $key
254        } elseif {$val eq "-"} {
255            lappend neg $key
256        }
257    }
258
259    # If there is no version, we have nothing to do
260    set composite_version ""
261    if {$version ne "" || $emptyVersionOkay} {
262        set pos_str ""
263        set neg_str ""
264
265        if {[llength $pos]} {
266            set pos_str "+[join [lsort -ascii $pos] "+"]"
267        }
268        if {[llength $neg]} {
269            set neg_str "-[join [lsort -ascii $neg] "-"]"
270        }
271
272        set composite_version "$version$pos_str$neg_str"
273    }
274
275    return $composite_version
276}
277
278
279proc split_variants {variants} {
280    set result {}
281    set l [regexp -all -inline -- {([-+])([[:alpha:]_]+[\w\.]*)} $variants]
282    foreach { match sign variant } $l {
283        lappend result $variant $sign
284    }
285    return $result
286}
287
288
289##
290# Maps friendly field names to their real name
291# Names which do not need mapping are not changed.
292#
293# @param field friendly name
294# @return real name
295proc map_friendly_field_names { field } {
296    switch -- $field {
297        variant -
298        platform -
299        maintainer -
300        subport {
301            set field "${field}s"
302        }
303        category {
304            set field "categories"
305        }
306    }
307
308    return $field
309}
310
311
312proc registry_installed {portname {portversion ""}} {
313    set ilist [registry::installed $portname $portversion]
314    if { [llength $ilist] > 1 } {
315        # set portname again since the one we were passed may not have had the correct case
316        set portname [lindex $ilist 0 0]
317        ui_notice "The following versions of $portname are currently installed:"
318        foreach i [portlist_sortint $ilist] {
319            set iname [lindex $i 0]
320            set iversion [lindex $i 1]
321            set irevision [lindex $i 2]
322            set ivariants [lindex $i 3]
323            set iactive [lindex $i 4]
324            if { $iactive == 0 } {
325                puts "  $iname @${iversion}_${irevision}${ivariants}"
326            } elseif { $iactive == 1 } {
327                puts "  $iname @${iversion}_${irevision}${ivariants} (active)"
328            }
329        }
330        return -code error "Registry error: Please specify the full version as recorded in the port registry."
331    } else {
332        return [lindex $ilist 0]
333    }
334}
335
336proc entry_for_portlist {portentry} {
337    global global_options global_variations
338
339    # Each portlist entry currently has the following elements in it:
340    #   url             if any
341    #   name
342    #   version         (version_revision)
343    #   variants array  (variant=>+-)
344    #   requested_variants array  (variant=>+-)
345    #   options array   (key=>value)
346    #   fullname        (name/version_revision+-variants)
347
348    array set port $portentry
349    if {![info exists port(url)]}       { set port(url) "" }
350    if {![info exists port(name)]}      { set port(name) "" }
351    if {![info exists port(version)]}   { set port(version) "" }
352    if {![info exists port(variants)]}  { set port(variants) "" }
353    if {![info exists port(requested_variants)]}  { set port(requested_variants) "" }
354    if {![info exists port(options)]}   { set port(options) [array get global_options] }
355
356    # If neither portname nor url is specified, then default to the current port
357    if { $port(url) eq "" && $port(name) eq "" } {
358        set url file://.
359        set portname [url_to_portname $url]
360        set port(url) $url
361        set port(name) $portname
362        if {$portname eq ""} {
363            ui_error "A default port name could not be supplied."
364        }
365    }
366
367    # Form the fully discriminated portname: portname/version_revison+-variants
368    set port(fullname) "$port(name)/[composite_version $port(version) $port(variants)]"
369   
370    return [array get port]
371}
372
373
374proc add_to_portlist {listname portentry} {
375    upvar $listname portlist
376   
377    # Form portlist entry and add to portlist
378    lappend portlist [entry_for_portlist $portentry]
379}
380
381
382proc add_ports_to_portlist {listname ports {overridelist ""}} {
383    upvar $listname portlist
384
385    array set overrides $overridelist
386
387    # Add each entry to the named portlist, overriding any values
388    # specified as overrides
389    foreach portentry $ports {
390        array set port $portentry
391        if ([info exists overrides(version)])   { set port(version) $overrides(version) }
392        if ([info exists overrides(variants)])  { set port(variants) $overrides(variants) }
393        if ([info exists overrides(requested_variants)])  { set port(requested_variants) $overrides(requested_variants) }
394        if ([info exists overrides(options)])   { set port(options) $overrides(options) }
395        add_to_portlist portlist [array get port]
396    }
397}
398
399
400proc url_to_portname { url {quiet 0} } {
401    # Save directory and restore the directory, since mportopen changes it
402    set savedir [pwd]
403    set portname ""
404    if {[catch {set ctx [mportopen $url]} result]} {
405        if {!$quiet} {
406            ui_msg "Can't map the URL '$url' to a port description file (\"${result}\")."
407            ui_msg "Please verify that the directory and portfile syntax are correct."
408        }
409    } else {
410        array set portinfo [mportinfo $ctx]
411        set portname $portinfo(name)
412        mportclose $ctx
413    }
414    cd $savedir
415    return $portname
416}
417
418
419# Supply a default porturl/portname if the portlist is empty
420proc require_portlist { nameportlist {is_upgrade "no"} } {
421    global private_options
422    upvar $nameportlist portlist
423
424    if {[llength $portlist] == 0 && (![info exists private_options(ports_no_args)] || $private_options(ports_no_args) eq "no")} {
425        if {${is_upgrade} == "yes"} {
426            # $> port upgrade outdated
427            # Error: No ports matched the given expression
428            # is not very user friendly - if we're in the special case of
429            # "upgrade", let's print a message that's a little easier to
430            # understand and less alarming.
431            ui_msg "Nothing to upgrade."
432            return 1
433        }
434        ui_error "No ports matched the given expression"
435        return 1
436    }
437
438    if {[llength $portlist] == 0} {
439        set portlist [get_current_port]
440
441        if {[llength $portlist] == 0} {
442            # there was no port in current directory
443            return 1
444        }
445    }
446
447    return 0
448}
449
450
451# Execute the enclosed block once for every element in the portlist
452# When the block is entered, the following variables will have been set:
453#   portspec, porturl, portname, portversion, options, variations, requested_variations
454proc foreachport {portlist block} {
455    set savedir [pwd]
456    foreach portspec $portlist {
457   
458        # Set the variables for the block
459        uplevel 1 "array unset portspec; array set portspec { $portspec }"
460        uplevel 1 {
461            set porturl $portspec(url)
462            set portname $portspec(name)
463            set portversion $portspec(version)
464            array unset variations
465            array set variations $portspec(variants)
466            array unset requested_variations
467            array set requested_variations $portspec(requested_variants)
468            array unset options
469            array set options $portspec(options)
470        }
471       
472        # Invoke block
473        uplevel 1 $block
474       
475        # Restore cwd after each port, since mportopen changes it, and otherwise relative
476        # urls would break on subsequent passes
477        if {[file exists $savedir]} {
478            cd $savedir
479        } else {
480            cd ~
481        }
482    }
483}
484
485
486proc portlist_compare { a b } {
487    array set a_ $a
488    array set b_ $b
489    set namecmp [string equal -nocase $a_(name) $b_(name)]
490    if {$namecmp != 1} {
491        if {$a_(name) eq [lindex [lsort -dictionary [list $a_(name) $b_(name)]] 0]} {
492            return -1
493        }
494        return 1
495    }
496    set avr_ [split $a_(version) "_"]
497    set bvr_ [split $b_(version) "_"]
498    set versioncmp [vercmp [lindex $avr_ 0] [lindex $bvr_ 0]]
499    if {$versioncmp != 0} {
500        return $versioncmp
501    }
502    set ar_ [lindex $avr_ 1]
503    set br_ [lindex $bvr_ 1]
504    if {$ar_ < $br_} {
505        return -1
506    } elseif {$ar_ > $br_} {
507        return 1
508    } else {
509        return 0
510    }
511}
512
513# Sort two ports in NVR (name@version_revision) order
514proc portlist_sort { list } {
515    return [lsort -command portlist_compare $list]
516}
517
518proc portlist_compareint { a b } {
519    array set a_ [list "name" [lindex $a 0] "version" "[lindex $a 1]_[lindex $a 2]"]
520    array set b_ [list "name" [lindex $b 0] "version" "[lindex $b 1]_[lindex $b 2]"]
521    return [portlist_compare [array get a_] [array get b_]]
522}
523
524# Same as portlist_sort, but with numeric indexes {name version revision}
525proc portlist_sortint { list } {
526    return [lsort -command portlist_compareint $list]
527}
528
529# sort portlist so dependents come before their dependencies
530proc portlist_sortdependents { portlist } {
531    foreach p $portlist {
532        array set pvals $p
533        lappend entries($pvals(name)) $p
534        if {![info exists dependents($pvals(name))]} {
535            set dependents($pvals(name)) {}
536            foreach result [registry::list_dependents $pvals(name)] {
537                lappend dependents($pvals(name)) [lindex $result 2]
538            }
539        }
540        array unset pvals
541    }
542    set ret {}
543    foreach p $portlist {
544        portlist_sortdependents_helper $p entries dependents seen ret
545    }
546    return $ret
547}
548
549proc portlist_sortdependents_helper {p up_entries up_dependents up_seen up_retlist} {
550    upvar $up_seen seen
551    if {![info exists seen($p)]} {
552        set seen($p) 1
553        upvar $up_entries entries $up_dependents dependents $up_retlist retlist
554        array set pvals $p
555        foreach dependent $dependents($pvals(name)) {
556            if {[info exists entries($dependent)]} {
557                foreach entry $entries($dependent) {
558                    portlist_sortdependents_helper $entry entries dependents seen retlist
559                }
560            }
561        }
562        lappend retlist $p
563    }
564}
565
566proc regex_pat_sanitize { s } {
567    set sanitized [regsub -all {[\\(){}+$.^]} $s {\\&}]
568    return $sanitized
569}
570
571##
572# Makes sure we get the current terminal size
573proc term_init_size {} {
574    global env
575
576    if {![info exists env(COLUMNS)] || ![info exists env(LINES)]} {
577        if {[isatty stdout]} {
578            set size [term_get_size stdout]
579
580            if {![info exists env(LINES)] && [lindex $size 0] > 0} {
581                set env(LINES) [lindex $size 0]
582            }
583
584            if {![info exists env(COLUMNS)] && [lindex $size 1] > 0} {
585                set env(COLUMNS) [lindex $size 1]
586            }
587        }
588    }
589}
590
591##
592# Wraps a multi-line string at specified textwidth
593#
594# @see wrapline
595#
596# @param string input string
597# @param maxlen text width (0 defaults to current terminal width)
598# @param indent prepend to every line
599# @return wrapped string
600proc wrap {string maxlen {indent ""} {indentfirstline 1}} {
601    global env
602
603    if {$maxlen == 0} {
604        if {![info exists env(COLUMNS)]} {
605            # no width for wrapping
606            return $string
607        }
608        set maxlen $env(COLUMNS)
609    }
610
611    set splitstring {}
612    set indentline $indentfirstline
613    foreach line [split $string "\n"] {
614        lappend splitstring [wrapline $line $maxlen $indent $indentline]
615        set indentline 1
616    }
617    return [join $splitstring "\n"]
618}
619
620##
621# Wraps a line at specified textwidth
622#
623# @see wrap
624#
625# @param line input line
626# @param maxlen text width (0 defaults to current terminal width)
627# @param indent prepend to every line
628# @return wrapped string
629proc wrapline {line maxlen {indent ""} {indentfirstline 1}} {
630    global env
631
632    if {$maxlen == 0} {
633        if {![info exists env(COLUMNS)]} {
634            # no width for wrapping
635            return $string
636        }
637        set maxlen $env(COLUMNS)
638    }
639
640    set string [split $line " "]
641    if {$indentfirstline == 0} {
642        set newline ""
643        set maxlen [expr {$maxlen - [string length $indent]}]
644    } else {
645        set newline $indent
646    }
647    append newline [lindex $string 0]
648    set joiner " "
649    set first 1
650    foreach word [lrange $string 1 end] {
651        if {[string length $newline]+[string length $word] >= $maxlen} {
652            lappend lines $newline
653            set newline $indent
654            set joiner ""
655            # If indentfirstline is set to 0, reset maxlen to its
656            # original length after appending the first line to lines.
657            if {$first == 1 && $indentfirstline == 0} {
658                set maxlen [expr {$maxlen + [string length $indent]}]
659            }
660            set first 0
661        }
662        append newline $joiner $word
663        set joiner " "
664    }
665    lappend lines $newline
666    return [join $lines "\n"]
667}
668
669##
670# Wraps a line at a specified width with a label in front
671#
672# @see wrap
673#
674# @param label label for output
675# @param string input string
676# @param maxlen text width (0 defaults to current terminal width)
677# @return wrapped string
678proc wraplabel {label string maxlen {indent ""}} {
679    append label ": [string repeat " " [expr {[string length $indent] - [string length "$label: "]}]]"
680    return "$label[wrap $string $maxlen $indent 0]"
681}
682
683proc unobscure_maintainers { list } {
684    set result {}
685    foreach m $list {
686        if {[string first "@" $m] < 0} {
687            if {[string first ":" $m] >= 0} {
688                set m [regsub -- "(.*):(.*)" $m "\\2@\\1"] 
689            } elseif {$m ne "openmaintainer" && $m ne "nomaintainer"} {
690                set m "$m@macports.org"
691            }
692        }
693        lappend result $m
694    }
695    return $result
696}
697
698
699##########################################
700# Port selection
701##########################################
702proc unique_results_to_portlist {infos} {
703    set result {}
704    array unset unique
705    foreach {name info} $infos {
706        array unset portinfo
707        array set portinfo $info
708       
709        set portentry [entry_for_portlist [list url $portinfo(porturl) name $name]]
710       
711        array unset entry
712        array set entry $portentry
713       
714        if {[info exists unique($entry(fullname))]} continue
715        set unique($entry(fullname)) 1
716       
717        lappend result $portentry
718    }
719    return $result
720}
721
722
723proc get_matching_ports {pattern {casesensitive no} {matchstyle glob} {field name}} {
724    if {[catch {set res [mportsearch $pattern $casesensitive $matchstyle $field]} result]} {
725        global errorInfo
726        ui_debug "$errorInfo"
727        fatal "search for portname $pattern failed: $result"
728    }
729    set results [unique_results_to_portlist $res]
730   
731    # Return the list of all ports, sorted
732    return [portlist_sort $results]
733}
734
735
736proc get_all_ports {} {
737    global all_ports_cache
738
739    if {![info exists all_ports_cache]} {
740         if {[catch {set res [mportlistall]} result]} {
741            global errorInfo
742            ui_debug "$errorInfo"
743            fatal "listing all ports failed: $result"
744        }
745        set results [unique_results_to_portlist $res]
746        set all_ports_cache [portlist_sort $results]
747    }
748    return $all_ports_cache
749}
750
751
752proc get_current_ports {} {
753    # This is just a synonym for get_current_port that
754    # works with the regex in element
755    return [get_current_port]
756}
757
758
759proc get_current_port {} {
760    set url file://.
761    set portname [url_to_portname $url]
762    if {$portname eq ""} {
763        ui_msg "To use the current port, you must be in a port's directory."
764        return [list]
765    }
766
767    set results {}
768    add_to_portlist results [list url $url name $portname]
769    return $results
770}
771
772
773proc get_installed_ports { {ignore_active yes} {active yes} } {
774    set ilist {}
775    if { [catch {set ilist [registry::installed]} result] } {
776        if {$result ne "Registry error: No ports registered as installed."} {
777            global errorInfo
778            ui_debug "$errorInfo"
779            fatal "port installed failed: $result"
780        }
781    }
782
783    set results {}
784    foreach i $ilist {
785        set iname [lindex $i 0]
786        set iversion [lindex $i 1]
787        set irevision [lindex $i 2]
788        set ivariants [split_variants [lindex $i 3]]
789        set iactive [lindex $i 4]
790
791        if { ${ignore_active} == "yes" || (${active} == "yes") == (${iactive} != 0) } {
792            add_to_portlist results [list name $iname version "${iversion}_${irevision}" variants $ivariants]
793        }
794    }
795
796    # Return the list of ports, sorted
797    return [portlist_sort $results]
798}
799
800
801proc get_uninstalled_ports {} {
802    # Return all - installed
803    set all [get_all_ports]
804    set installed [get_installed_ports]
805    return [opComplement $all $installed]
806}
807
808
809proc get_active_ports {} {
810    return [get_installed_ports no yes]
811}
812
813
814proc get_inactive_ports {} {
815    return [get_installed_ports no no]
816}
817
818proc get_actinact_ports {} {
819    set inactive_ports [get_inactive_ports]
820    set active_ports [get_active_ports]
821    set results {}
822
823    foreach port $inactive_ports {
824        array set portspec $port
825        set portname $portspec(name)
826        lappend inact($portname) $port
827    }
828
829    foreach port $active_ports {
830        array set portspec $port
831        set portname $portspec(name)
832
833        if {[info exists inact($portname)]} {
834            if {![info exists added_inact($portname)]} {
835                foreach inact_spec $inact($portname) {
836                    lappend results $inact_spec
837                }
838                set added_inact($portname) 1
839            }
840            lappend results $port
841        }
842    }
843    return $results
844}
845
846
847proc get_outdated_ports {} {
848    # Get the list of installed ports
849    set ilist {}
850    if { [catch {set ilist [registry::installed]} result] } {
851        if {$result ne "Registry error: No ports registered as installed."} {
852            global errorInfo
853            ui_debug "$errorInfo"
854            fatal "port installed failed: $result"
855        }
856    }
857
858    # Now process the list, keeping only those ports that are outdated
859    set results {}
860    if { [llength $ilist] > 0 } {
861        foreach i $ilist {
862
863            # Get information about the installed port
864            set portname            [lindex $i 0]
865            set installed_version   [lindex $i 1]
866            set installed_revision  [lindex $i 2]
867            set installed_compound  "${installed_version}_${installed_revision}"
868            set installed_variants  [lindex $i 3]
869
870            set is_active           [lindex $i 4]
871            if {$is_active == 0} continue
872
873            set installed_epoch     [lindex $i 5]
874
875            # Get info about the port from the index
876            if {[catch {set res [mportlookup $portname]} result]} {
877                global errorInfo
878                ui_debug "$errorInfo"
879                fatal "lookup of portname $portname failed: $result"
880            }
881            if {[llength $res] < 2} {
882                if {[macports::ui_isset ports_debug]} {
883                    puts stderr "$portname ($installed_compound is installed; the port was not found in the port index)"
884                }
885                continue
886            }
887            array unset portinfo
888            array set portinfo [lindex $res 1]
889
890            # Get information about latest available version and revision
891            set latest_version $portinfo(version)
892            set latest_revision     0
893            if {[info exists portinfo(revision)] && $portinfo(revision) > 0} { 
894                set latest_revision $portinfo(revision)
895            }
896            set latest_compound     "${latest_version}_${latest_revision}"
897            set latest_epoch        0
898            if {[info exists portinfo(epoch)]} { 
899                set latest_epoch    $portinfo(epoch)
900            }
901
902            # Compare versions, first checking epoch, then version, then revision
903            set comp_result 0
904            if {$installed_version != $latest_version} {
905                set comp_result [expr {$installed_epoch - $latest_epoch}]
906                if { $comp_result == 0 } {
907                    set comp_result [vercmp $installed_version $latest_version]
908                }
909            }
910            if { $comp_result == 0 } {
911                set comp_result [expr {$installed_revision - $latest_revision}]
912            }
913            if {$comp_result == 0} {
914                set regref [registry::open_entry $portname $installed_version $installed_revision $installed_variants $installed_epoch]
915                set os_platform_installed [registry::property_retrieve $regref os_platform]
916                set os_major_installed [registry::property_retrieve $regref os_major]
917                if {$os_platform_installed ne "" && $os_platform_installed != 0
918                    && $os_major_installed ne "" && $os_major_installed != 0
919                    && ($os_platform_installed != ${macports::os_platform} || $os_major_installed != ${macports::os_major})} {
920                    set comp_result -1
921                }
922            }
923
924            # Add outdated ports to our results list
925            if { $comp_result < 0 } {
926                add_to_portlist results [list name $portname version $installed_compound variants [split_variants $installed_variants]]
927            }
928        }
929    }
930
931    return [portlist_sort $results]
932}
933
934
935proc get_obsolete_ports {} {
936    set ilist [get_installed_ports]
937    set results {}
938
939    foreach i $ilist {
940        array set port $i
941
942        if {[catch {mportlookup $port(name)} result]} {
943            ui_debug "$::errorInfo"
944            break_softcontinue "lookup of portname $portname failed: $result" 1 status
945        }
946
947        if {[llength $result] < 2} {
948            lappend results $i
949        }
950    }
951
952    # Return the list of ports, already sorted
953    return [portlist_sort $results]
954}
955
956# return ports that have registry property $propname set to $propval
957proc get_ports_with_prop {propname propval} {
958    set ilist {}
959    if { [catch {set ilist [registry::installed]} result] } {
960        if {$result ne "Registry error: No ports registered as installed."} {
961            global errorInfo
962            ui_debug "$errorInfo"
963            fatal "port installed failed: $result"
964        }
965    }
966
967    set results {}
968    foreach i $ilist {
969        set iname [lindex $i 0]
970        set iversion [lindex $i 1]
971        set irevision [lindex $i 2]
972        set ivariants [lindex $i 3]
973        set iepoch [lindex $i 5]
974        set regref [registry::open_entry $iname $iversion $irevision $ivariants $iepoch]
975        if {[registry::property_retrieve $regref $propname] == $propval} {
976            add_to_portlist results [list name $iname version "${iversion}_${irevision}" variants [split_variants $ivariants]]
977        }
978    }
979
980    # Return the list of ports, sorted
981    return [portlist_sort $results]
982}
983
984proc get_requested_ports {} {
985    return [get_ports_with_prop requested 1]
986}
987
988proc get_unrequested_ports {} {
989    return [get_ports_with_prop requested 0]
990}
991
992proc get_leaves_ports {} {
993    set ilist {}
994    if { [catch {set ilist [registry::installed]} result] } {
995        if {$result ne "Registry error: No ports registered as installed."} {
996            global errorInfo
997            ui_debug "$errorInfo"
998            fatal "port installed failed: $result"
999        }
1000    }
1001    registry::open_dep_map
1002    set results {}
1003    foreach i $ilist {
1004        set iname [lindex $i 0]
1005        if {[registry::list_dependents $iname] eq ""} {
1006            add_to_portlist results [list name $iname version "[lindex $i 1]_[lindex $i 2]" variants [split_variants [lindex $i 3]]]
1007        }
1008    }
1009    return [portlist_sort [opIntersection $results [get_unrequested_ports]]]
1010}
1011
1012proc get_dependent_ports {portname recursive} {
1013    registry::open_dep_map
1014    set deplist [registry::list_dependents $portname]
1015    # could return specific versions here using registry2.0 features
1016    set results {}
1017    foreach dep $deplist {
1018        add_to_portlist results [list name [lindex $dep 2]]
1019    }
1020
1021    # actually do this iteratively to avoid hitting Tcl's recursion limit
1022    if {$recursive} {
1023        while 1 {
1024            set rportlist {}
1025            set newlist {}
1026            foreach dep $deplist {
1027                set depname [lindex $dep 2]
1028                if {![info exists seen($depname)]} {
1029                    set seen($depname) 1
1030                    set rdeplist [registry::list_dependents $depname]
1031                    foreach rdep $rdeplist {
1032                        lappend newlist $rdep
1033                        add_to_portlist rportlist [list name [lindex $rdep 2]]
1034                    }
1035                }
1036            }
1037            if {[llength $rportlist] > 0} {
1038                set results [opUnion $results $rportlist]
1039                set deplist $newlist
1040            } else {
1041                break
1042            }
1043        }
1044    }
1045
1046    return [portlist_sort $results]
1047}
1048
1049
1050proc get_dep_ports {portname recursive} {
1051    global global_variations
1052
1053    # look up portname
1054    if {[catch {mportlookup $portname} result]} {
1055        ui_debug "$::errorInfo"
1056        return -code error "lookup of portname $portname failed: $result"
1057    }
1058    if {[llength $result] < 2} {
1059        return -code error "Port $portname not found"
1060    }
1061    array unset portinfo
1062    array set portinfo [lindex $result 1]
1063    set porturl $portinfo(porturl)
1064
1065    # open portfile
1066    if {[catch {set mport [mportopen $porturl [list subport $portinfo(name)] [array get global_variations]]} result]} {
1067        ui_debug "$::errorInfo"
1068        return -code error "Unable to open port: $result"
1069    }
1070    array unset portinfo
1071    array set portinfo [mportinfo $mport]
1072    mportclose $mport
1073
1074    # gather its deps
1075    set results {}
1076    set deptypes {depends_fetch depends_extract depends_build depends_lib depends_run}
1077
1078    set deplist {}
1079    foreach type $deptypes {
1080        if {[info exists portinfo($type)]} {
1081            foreach dep $portinfo($type) {
1082                add_to_portlist results [list name [lindex [split $dep :] end]]
1083                lappend deplist $dep
1084            }
1085        }
1086    }
1087
1088    # actually do this iteratively to avoid hitting Tcl's recursion limit
1089    if {$recursive} {
1090        while 1 {
1091            set rportlist {}
1092            set newlist {}
1093            foreach dep $deplist {
1094                set depname [lindex [split $dep :] end]
1095                if {![info exists seen($depname)]} {
1096                    set seen($depname) 1
1097
1098                    # look up the dep
1099                    if {[catch {mportlookup $depname} result]} {
1100                        ui_debug "$::errorInfo"
1101                        return -code error "lookup of portname $depname failed: $result"
1102                    }
1103                    if {[llength $result] < 2} {
1104                        ui_error "Port $depname not found"
1105                        continue
1106                    }
1107                    array unset portinfo
1108                    array set portinfo [lindex $result 1]
1109                    set porturl $portinfo(porturl)
1110               
1111                    # open its portfile
1112                    if {[catch {set mport [mportopen $porturl [list subport $portinfo(name)] [array get global_variations]]} result]} {
1113                        ui_debug "$::errorInfo"
1114                        ui_error "Unable to open port: $result"
1115                        continue
1116                    }
1117                    array unset portinfo
1118                    array set portinfo [mportinfo $mport]
1119                    mportclose $mport
1120
1121                    # collect its deps
1122                    set rdeplist {}
1123                    foreach type $deptypes {
1124                        if {[info exists portinfo($type)]} {
1125                            foreach rdep $portinfo($type) {
1126                                add_to_portlist results [list name [lindex [split $rdep :] end]]
1127                                lappend rdeplist $rdep
1128                            }
1129                        }
1130                    }
1131
1132                    # add them to the lists
1133                    foreach rdep $rdeplist {
1134                        lappend newlist $rdep
1135                        add_to_portlist rportlist [list name [lindex [split $rdep :] end]]
1136                    }
1137                }
1138            }
1139            if {[llength $rportlist] > 0} {
1140                set results [opUnion $results $rportlist]
1141                set deplist $newlist
1142            } else {
1143                break
1144            }
1145        }
1146    }
1147
1148    return [portlist_sort $results]
1149}
1150
1151proc get_subports {portname} {
1152    global global_variations
1153
1154    # look up portname
1155    if {[catch {mportlookup $portname} result]} {
1156        ui_debug "$::errorInfo"
1157        return -code error "lookup of portname $portname failed: $result"
1158    }
1159    if {[llength $result] < 2} {
1160        return -code error "Port $portname not found"
1161    }
1162    array unset portinfo
1163    array set portinfo [lindex $result 1]
1164    set porturl $portinfo(porturl)
1165
1166    # open portfile
1167    if {[catch {set mport [mportopen $porturl [list subport $portinfo(name)] [array get global_variations]]} result]} {
1168        ui_debug "$::errorInfo"
1169        return -code error "Unable to open port: $result"
1170    }
1171    array unset portinfo
1172    array set portinfo [mportinfo $mport]
1173    mportclose $mport
1174
1175    # gather its subports
1176    set results {}
1177
1178    if {[info exists portinfo(subports)]} {
1179        foreach subport $portinfo(subports) {
1180            add_to_portlist results [list name $subport]
1181        }
1182    }
1183
1184    return [portlist_sort $results]
1185}
1186
1187
1188##########################################
1189# Port expressions
1190##########################################
1191proc portExpr { resname } {
1192    upvar $resname reslist
1193    set result [seqExpr reslist]
1194    return $result
1195}
1196
1197
1198proc seqExpr { resname } {
1199    upvar $resname reslist
1200   
1201    # Evaluate a sequence of expressions a b c...
1202    # These act the same as a or b or c
1203
1204    set result 1
1205    while {$result} {
1206        switch -- [lookahead] {
1207            ;       -
1208            )       -
1209            _EOF_   { break }
1210        }
1211
1212        set blist {}
1213        set result [orExpr blist]
1214        if {$result} {
1215            # Calculate the union of result and b
1216            set reslist [opUnion $reslist $blist]
1217        }
1218    }
1219   
1220    return $result
1221}
1222
1223
1224proc orExpr { resname } {
1225    upvar $resname reslist
1226   
1227    set a [andExpr reslist]
1228    while ($a) {
1229        switch -- [lookahead] {
1230            or {
1231                    advance
1232                    set blist {}
1233                    if {![andExpr blist]} {
1234                        return 0
1235                    }
1236                       
1237                    # Calculate a union b
1238                    set reslist [opUnion $reslist $blist]
1239                }
1240            default {
1241                    return $a
1242                }
1243        }
1244    }
1245   
1246    return $a
1247}
1248
1249
1250proc andExpr { resname } {
1251    upvar $resname reslist
1252   
1253    set a [unaryExpr reslist]
1254    while {$a} {
1255        switch -- [lookahead] {
1256            and {
1257                    advance
1258                   
1259                    set blist {}
1260                    set b [unaryExpr blist]
1261                    if {!$b} {
1262                        return 0
1263                    }
1264                   
1265                    # Calculate a intersect b
1266                    set reslist [opIntersection $reslist $blist]
1267                }
1268            default {
1269                    return $a
1270                }
1271        }
1272    }
1273   
1274    return $a
1275}
1276
1277
1278proc unaryExpr { resname } {
1279    upvar $resname reslist
1280    set result 0
1281
1282    switch -- [lookahead] {
1283        !   -
1284        not {
1285                advance
1286                set blist {}
1287                set result [unaryExpr blist]
1288                if {$result} {
1289                    set all [get_all_ports]
1290                    set reslist [opComplement $all $blist]
1291                }
1292            }
1293        default {
1294                set result [element reslist]
1295            }
1296    }
1297   
1298    return $result
1299}
1300
1301
1302proc element { resname } {
1303    upvar $resname reslist
1304    set el 0
1305   
1306    set url ""
1307    set name ""
1308    set version ""
1309    array unset requested_variants
1310    array unset options
1311   
1312    set token [lookahead]
1313    switch -regex -- $token {
1314        ^\\)$               -
1315        ^\;                 -
1316        ^_EOF_$             { # End of expression/cmd/file
1317        }
1318
1319        ^\\($               { # Parenthesized Expression
1320            advance
1321            set el [portExpr reslist]
1322            if {!$el || ![match ")"]} {
1323                set el 0
1324            }
1325        }
1326
1327        ^all(@.*)?$         -
1328        ^installed(@.*)?$   -
1329        ^uninstalled(@.*)?$ -
1330        ^active(@.*)?$      -
1331        ^inactive(@.*)?$    -
1332        ^actinact(@.*)?$    -
1333        ^leaves(@.*)?$      -
1334        ^outdated(@.*)?$    -
1335        ^obsolete(@.*)?$    -
1336        ^requested(@.*)?$   -
1337        ^unrequested(@.*)?$ -
1338        ^current(@.*)?$     {
1339            # A simple pseudo-port name
1340            advance
1341
1342            # Break off the version component, if there is one
1343            regexp {^(\w+)(@.*)?} $token matchvar name remainder
1344
1345            add_multiple_ports reslist [get_${name}_ports] $remainder
1346
1347            set el 1
1348        }
1349
1350        ^variants:          -
1351        ^variant:           -
1352        ^description:       -
1353        ^portdir:           -
1354        ^homepage:          -
1355        ^epoch:             -
1356        ^platforms:         -
1357        ^platform:          -
1358        ^name:              -
1359        ^long_description:  -
1360        ^maintainers:       -
1361        ^maintainer:        -
1362        ^categories:        -
1363        ^category:          -
1364        ^version:           -
1365        ^depends_lib:       -
1366        ^depends_build:     -
1367        ^depends_run:       -
1368        ^depends_extract:   -
1369        ^depends_fetch:     -
1370        ^replaced_by:       -
1371        ^revision:          -
1372        ^subport:           -
1373        ^subports:          -
1374        ^license:           { # Handle special port selectors
1375            advance
1376
1377            # Break up the token, because older Tcl switch doesn't support -matchvar
1378            regexp {^(\w+):(.*)} $token matchvar field pat
1379
1380            # Remap friendly names to actual names
1381            set field [map_friendly_field_names $field]
1382
1383            add_multiple_ports reslist [get_matching_ports $pat no regexp $field]
1384            set el 1
1385        }
1386
1387        ^depends:           { # A port selector shorthand for depends_{lib,build,run,fetch,extract}
1388            advance
1389
1390            # Break up the token, because older Tcl switch doesn't support -matchvar
1391            regexp {^(\w+):(.*)} $token matchvar field pat
1392
1393            add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_lib"]
1394            add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_build"]
1395            add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_run"]
1396            add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_extract"]
1397            add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_fetch"]
1398
1399            set el 1
1400        }
1401
1402        ^dependentof:       -
1403        ^rdependentof:      {
1404            advance
1405
1406            # Break up the token, because older Tcl switch doesn't support -matchvar
1407            regexp {^(\w+):(.*)} $token matchvar selector portname
1408
1409            set recursive [string equal $selector "rdependentof"]
1410            add_multiple_ports reslist [get_dependent_ports $portname $recursive]
1411           
1412            set el 1
1413        }
1414       
1415        ^depof:             -
1416        ^rdepof:            {
1417            advance
1418
1419            # Break up the token, because older Tcl switch doesn't support -matchvar
1420            regexp {^(\w+):(.*)} $token matchvar selector portname
1421
1422            set recursive [string equal $selector "rdepof"]
1423            add_multiple_ports reslist [get_dep_ports $portname $recursive]
1424           
1425            set el 1
1426        }
1427
1428        ^subportof:         {
1429            advance
1430
1431            # Break up the token, because older Tcl switch doesn't support -matchvar
1432            regexp {^(\w+):(.*)} $token matchvar selector portname
1433
1434            add_multiple_ports reslist [get_subports $portname]
1435
1436            set el 1
1437        }
1438
1439        [][?*]              { # Handle portname glob patterns
1440            advance; add_multiple_ports reslist [get_matching_ports $token no glob]
1441            set el 1
1442        }
1443
1444        ^\\w+:.+            { # Handle a url by trying to open it as a port and mapping the name
1445            advance
1446            set name [url_to_portname $token]
1447            if {$name ne ""} {
1448                parsePortSpec version requested_variants options
1449                add_to_portlist reslist [list url $token \
1450                  name $name \
1451                  version $version \
1452                  requested_variants [array get requested_variants] \
1453                  variants [array get requested_variants] \
1454                  options [array get options]]
1455                set el 1
1456            } else {
1457                ui_error "Can't open URL '$token' as a port"
1458                set el 0
1459            }
1460        }
1461
1462        default             { # Treat anything else as a portspec (portname, version, variants, options
1463            # or some combination thereof).
1464            parseFullPortSpec url name version requested_variants options
1465            add_to_portlist reslist [list url $url \
1466              name $name \
1467              version $version \
1468              requested_variants [array get requested_variants] \
1469              variants [array get requested_variants] \
1470              options [array get options]]
1471            set el 1
1472        }
1473    }
1474
1475    return $el
1476}
1477
1478
1479proc add_multiple_ports { resname ports {remainder ""} } {
1480    upvar $resname reslist
1481   
1482    set version ""
1483    array unset variants
1484    array unset options
1485    parsePortSpec version variants options $remainder
1486   
1487    array unset overrides
1488    if {$version ne ""} { set overrides(version) $version }
1489    if {[array size variants]} {
1490        # we always record the requested variants separately,
1491        # but requested ones always override existing ones
1492        set overrides(requested_variants) [array get variants]
1493        set overrides(variants) [array get variants]
1494    }
1495    if {[array size options]} { set overrides(options) [array get options] }
1496
1497    add_ports_to_portlist reslist $ports [array get overrides]
1498}
1499
1500
1501proc unique_entries { entries } {
1502    # Form the list of all the unique elements in the list a,
1503    # considering only the port fullname, and taking the first
1504    # found element first
1505    set result {}
1506    array unset unique
1507    foreach item $entries {
1508        array set port $item
1509        if {[info exists unique($port(fullname))]} continue
1510        set unique($port(fullname)) 1
1511        lappend result $item
1512    }
1513    return $result
1514}
1515
1516
1517proc opUnion { a b } {
1518    # Return the unique elements in the combined two lists
1519    return [unique_entries [concat $a $b]]
1520}
1521
1522
1523proc opIntersection { a b } {
1524    set result {}
1525   
1526    # Rules we follow in performing the intersection of two port lists:
1527    #
1528    #   a/, a/          ==> a/
1529    #   a/, b/          ==>
1530    #   a/, a/1.0       ==> a/1.0
1531    #   a/1.0, a/       ==> a/1.0
1532    #   a/1.0, a/2.0    ==>
1533    #
1534    #   If there's an exact match, we take it.
1535    #   If there's a match between simple and discriminated, we take the later.
1536   
1537    # First create a list of the fully discriminated names in b
1538    array unset bfull
1539    set i 0
1540    foreach bitem [unique_entries $b] {
1541        array set port $bitem
1542        set bfull($port(fullname)) $i
1543        incr i
1544    }
1545   
1546    # Walk through each item in a, matching against b
1547    foreach aitem [unique_entries $a] {
1548        array set port $aitem
1549       
1550        # Quote the fullname and portname to avoid special characters messing up the regexp
1551        set safefullname [regex_pat_sanitize $port(fullname)]
1552       
1553        set simpleform [expr { "$port(name)/" == $port(fullname) }]
1554        if {$simpleform} {
1555            set pat "^${safefullname}"
1556        } else {
1557            set safename [regex_pat_sanitize $port(name)]
1558            set pat "^${safefullname}$|^${safename}/$"
1559        }
1560       
1561        set matches [array names bfull -regexp $pat]
1562        foreach match $matches {
1563            if {$simpleform} {
1564                set i $bfull($match)
1565                lappend result [lindex $b $i]
1566            } else {
1567                lappend result $aitem
1568            }
1569        }
1570    }
1571   
1572    return $result
1573}
1574
1575
1576proc opComplement { a b } {
1577    set result {}
1578   
1579    # Return all elements of a not matching elements in b
1580   
1581    # First create a list of the fully discriminated names in b
1582    array unset bfull
1583    set i 0
1584    foreach bitem $b {
1585        array set port $bitem
1586        set bfull($port(fullname)) $i
1587        incr i
1588    }
1589   
1590    # Walk through each item in a, taking all those items that don't match b
1591    foreach aitem $a {
1592        array set port $aitem
1593       
1594        # Quote the fullname and portname to avoid special characters messing up the regexp
1595        set safefullname [regex_pat_sanitize $port(fullname)]
1596       
1597        set simpleform [expr { "$port(name)/" == $port(fullname) }]
1598        if {$simpleform} {
1599            set pat "^${safefullname}"
1600        } else {
1601            set safename [regex_pat_sanitize $port(name)]
1602            set pat "^${safefullname}$|^${safename}/$"
1603        }
1604       
1605        set matches [array names bfull -regexp $pat]
1606
1607        # We copy this element to result only if it didn't match against b
1608        if {![llength $matches]} {
1609            lappend result $aitem
1610        }
1611    }
1612   
1613    return $result
1614}
1615
1616
1617proc parseFullPortSpec { urlname namename vername varname optname } {
1618    upvar $urlname porturl
1619    upvar $namename portname
1620    upvar $vername portversion
1621    upvar $varname portvariants
1622    upvar $optname portoptions
1623   
1624    set portname ""
1625    set portversion ""
1626    array unset portvariants
1627    array unset portoptions
1628   
1629    if { [moreargs] } {
1630        # Look first for a potential portname
1631        #
1632        # We need to allow a wide variety of tokens here, because of actions like "provides"
1633        # so we take a rather lenient view of what a "portname" is. We allow
1634        # anything that doesn't look like either a version, a variant, or an option
1635        set token [lookahead]
1636
1637        set remainder ""
1638        if {![regexp {^(@|[-+]([[:alpha:]_]+[\w\.]*)|[[:alpha:]_]+[\w\.]*=)} $token match]} {
1639            advance
1640            regexp {^([^@]+)(@.*)?} $token match portname remainder
1641           
1642            # If the portname contains a /, then try to use it as a URL
1643            if {[string match "*/*" $portname]} {
1644                set url "file://$portname"
1645                set name [url_to_portname $url 1]
1646                if { $name ne "" } {
1647                    # We mapped the url to valid port
1648                    set porturl $url
1649                    set portname $name
1650                    # Continue to parse rest of portspec....
1651                } else {
1652                    # We didn't map the url to a port; treat it
1653                    # as a raw string for something like port contents
1654                    # or cd
1655                    set porturl ""
1656                    # Since this isn't a port, we don't try to parse
1657                    # any remaining portspec....
1658                    return
1659                }
1660            }
1661        }
1662       
1663        # Now parse the rest of the spec
1664        parsePortSpec portversion portvariants portoptions $remainder
1665    }
1666}
1667
1668# check if the install prefix is writable
1669# should be called by actions that will modify it
1670proc prefix_unwritable {} {
1671    global macports::portdbpath
1672    if {[file writable $portdbpath]} {
1673        return 0
1674    } else {
1675        ui_error "Insufficient privileges to write to MacPorts install prefix."
1676        return 1
1677    }
1678}
1679
1680   
1681proc parsePortSpec { vername varname optname {remainder ""} } {
1682    upvar $vername portversion
1683    upvar $varname portvariants
1684    upvar $optname portoptions
1685   
1686    global global_options
1687   
1688    set portversion ""
1689    array unset portoptions
1690    array set portoptions [array get global_options]
1691    array unset portvariants
1692   
1693    # Parse port version/variants/options
1694    set opt $remainder
1695    set adv 0
1696    set consumed 0
1697    for {set firstTime 1} {$opt ne "" || [moreargs]} {set firstTime 0} {
1698   
1699        # Refresh opt as needed
1700        if {$opt eq ""} {
1701            if {$adv} advance
1702            set opt [lookahead]
1703            set adv 1
1704            set consumed 0
1705        }
1706       
1707        # Version must be first, if it's there at all
1708        if {$firstTime && [string match {@*} $opt]} {
1709            # Parse the version
1710           
1711            # Strip the @
1712            set opt [string range $opt 1 end]
1713           
1714            # Handle the version
1715            set sepPos [string first "/" $opt]
1716            if {$sepPos >= 0} {
1717                # Version terminated by "/" to disambiguate -variant from part of version
1718                set portversion [string range $opt 0 [expr {$sepPos - 1}]]
1719                set opt [string range $opt [expr {$sepPos + 1}] end]
1720            } else {
1721                # Version terminated by "+", or else is complete
1722                set sepPos [string first "+" $opt]
1723                if {$sepPos >= 0} {
1724                    # Version terminated by "+"
1725                    set portversion [string range $opt 0 [expr {$sepPos - 1}]]
1726                    set opt [string range $opt $sepPos end]
1727                } else {
1728                    # Unterminated version
1729                    set portversion $opt
1730                    set opt ""
1731                }
1732            }
1733            set consumed 1
1734        } else {
1735            # Parse all other options
1736           
1737            # Look first for a variable setting: VARNAME=VALUE
1738            if {[regexp {^([[:alpha:]_]+[\w\.]*)=(.*)} $opt match key val] == 1} {
1739                # It's a variable setting
1740                set portoptions($key) "\"$val\""
1741                set opt ""
1742                set consumed 1
1743            } elseif {[regexp {^([-+])([[:alpha:]_]+[\w\.]*)} $opt match sign variant] == 1} {
1744                # It's a variant
1745                set portvariants($variant) $sign
1746                set opt [string range $opt [expr {[string length $variant] + 1}] end]
1747                set consumed 1
1748            } else {
1749                # Not an option we recognize, so break from port option processing
1750                if { $consumed && $adv } advance
1751                break
1752            }
1753        }
1754    }
1755}
1756
1757
1758##########################################
1759# Action Handlers
1760##########################################
1761
1762proc action_get_usage { action } {
1763    global action_array cmd_opts_array
1764
1765    if {[info exists action_array($action)]} {
1766        set cmds ""
1767        if {[info exists cmd_opts_array($action)]} {
1768            foreach opt $cmd_opts_array($action) {
1769                if {[llength $opt] == 1} {
1770                    set name $opt
1771                    set optc 0
1772                } else {
1773                    set name [lindex $opt 0]
1774                    set optc [lindex $opt 1]
1775                }
1776
1777                append cmds " --$name"
1778
1779                for {set i 1} {$i <= $optc} {incr i} {
1780                    append cmds " <arg$i>"
1781                }
1782            }
1783        }
1784        set args ""
1785        set needed [action_needs_portlist $action]
1786        if {[ACTION_ARGS_STRINGS] == $needed} {
1787            set args " <arguments>"
1788        } elseif {[ACTION_ARGS_STRINGS] == $needed} {
1789            set args " <portlist>"
1790        }
1791
1792        set ret "Usage: "
1793        set len [string length $action]
1794        append ret [wrap "$action$cmds$args" 0 [string repeat " " [expr {8 + $len}]] 0]
1795        append ret "\n"
1796
1797        return $ret
1798    }
1799
1800    return -1
1801}
1802
1803proc action_usage { action portlist opts } {
1804    if {[llength $portlist] == 0} {
1805        print_usage
1806        return 0
1807    }
1808
1809    foreach topic $portlist {
1810        set usage [action_get_usage $topic]
1811        if {$usage != -1} {
1812           puts -nonewline stderr $usage
1813        } else {
1814            ui_error "No usage for topic $topic"
1815            return 1
1816        }
1817    }
1818    return 0
1819}
1820
1821
1822proc action_help { action portlist opts } {
1823    set manext ".gz"
1824    if {[llength $portlist] == 0} {
1825        set page "man1/port.1$manext"
1826    } else {
1827        set topic [lindex $portlist 0]
1828
1829        # Look for an action with the requested argument
1830        set actions [find_action $topic]
1831        if {[llength $actions] == 1} {
1832            set page "man1/port-[lindex $actions 0].1$manext"
1833        } else {
1834            if {[llength $actions] > 1} {
1835                ui_error "\"port help ${action}\" is ambiguous: \n  port help [join $actions "\n  port help "]"
1836                return 1
1837            }
1838
1839            # No valid command specified
1840            set page ""
1841        }
1842    }
1843
1844    set pagepath ${macports::prefix}/share/man/$page
1845    if {$page == "" || ![file exists $pagepath]} {
1846        set page "man7/portundocumented.7$manext"
1847        set pagepath ${macports::prefix}/share/man/$page
1848    }
1849
1850    if {$pagepath != ""} {
1851        ui_debug "Opening man page '$pagepath'"
1852
1853        # Restore our entire environment from start time.
1854        # man might want to evaluate TERM
1855        global env boot_env
1856        array unset env_save; array set env_save [array get env]
1857        array unset env *
1858        if {${macports::macosx_version} == "10.5"} {
1859            unsetenv *
1860        }
1861        array set env [array get boot_env]
1862
1863        if [catch {system -nodup "${macports::autoconf::man_path} $pagepath"} result] {
1864            ui_debug "$::errorInfo"
1865            ui_error "Unable to show man page using ${macports::autoconf::man_path}: $result"
1866            return 1
1867        }
1868
1869        # Restore internal MacPorts environment
1870        array unset env *
1871        if {${macports::macosx_version} == "10.5"} {
1872            unsetenv *
1873        }
1874        array set env [array get env_save]
1875    } else {
1876        ui_error "Sorry, no help for this topic is available."
1877        return 1
1878    }
1879
1880    return 0
1881}
1882
1883
1884proc action_log { action portlist opts } {
1885    global global_options
1886    if {[require_portlist portlist]} {
1887        return 1
1888    }
1889    foreachport $portlist {
1890        # If we have a url, use that, since it's most specific
1891        # otherwise try to map the portname to a url
1892        if {$porturl eq ""} {
1893        # Verify the portname, getting portinfo to map to a porturl
1894            if {[catch {mportlookup $portname} result]} {
1895                ui_debug "$::errorInfo"
1896                break_softcontinue "lookup of portname $portname failed: $result" 1 status
1897            }
1898            if {[llength $result] < 2} {
1899                break_softcontinue "Port $portname not found" 1 status
1900            }
1901            array unset portinfo
1902            array set portinfo [lindex $result 1]
1903            set porturl $portinfo(porturl)
1904            set portdir $portinfo(portdir)
1905            set portname $portinfo(name)
1906        } elseif {$porturl ne "file://."} {
1907            # Extract the portdir from porturl and use it to search PortIndex.
1908            # Only the last two elements of the path (porturl) make up the
1909            # portdir.
1910            set portdir [file split [macports::getportdir $porturl]]
1911            set lsize [llength $portdir]
1912            set portdir \
1913                [file join [lindex $portdir [expr {$lsize - 2}]] \
1914                           [lindex $portdir [expr {$lsize - 1}]]]
1915            if {[catch {mportsearch $portdir no exact portdir} result]} {
1916                ui_debug "$::errorInfo"
1917                break_softcontinue "Portdir $portdir not found" 1 status
1918            }
1919            if {[llength $result] < 2} {
1920                break_softcontinue "Portdir $portdir not found" 1 status
1921            }
1922            array unset portinfo
1923            set matchindex [lsearch -exact -nocase $result $portname]
1924            if {$matchindex != -1} {
1925                array set portinfo [lindex $result [incr matchindex]]
1926            } else {
1927                ui_warn "Portdir $portdir doesn't seem to belong to portname $portname"
1928                array set portinfo [lindex $result 1]
1929            }
1930            set portname $portinfo(name)
1931        }
1932        set portpath [macports::getportdir $porturl]
1933        set logfile [file join [macports::getportlogpath $portpath $portname] "main.log"]
1934        if {[file exists $logfile]} {
1935            if {[catch {set fp [open $logfile r]} result]} {
1936                break_softcontinue "Could not open file $logfile: $result" 1 status
1937            }
1938            set data [read $fp]
1939            set data [split $data "\n"]
1940
1941            if {[info exists global_options(ports_log_phase)]} {
1942                set phase $global_options(ports_log_phase);
1943            } else {
1944                set phase "\[a-z\]*"
1945            }
1946
1947            if {[info exists global_options(ports_log_level)]} {
1948                set index [lsearch -exact ${macports::ui_priorities} $global_options(ports_log_level)]
1949                if {$index == -1} {
1950                    set prefix ""
1951                } else {
1952                    set prefix [join [lrange ${macports::ui_priorities} 0 $index] "|"]
1953                }
1954            } else {
1955                set prefix "\[a-z\]*"
1956            }
1957            foreach line $data {
1958                set exp "^:($prefix|any):($phase|any) (.*)$"
1959                if {[regexp $exp $line -> lpriority lphase lmsg] == 1} {
1960                    puts "[macports::ui_prefix_default $lpriority]$lmsg"
1961                }
1962            }
1963
1964            close $fp
1965        } else {
1966            break_softcontinue "Log file for port $portname not found" 1 status
1967        }
1968    }
1969    return 0
1970}
1971
1972
1973proc action_info { action portlist opts } {
1974    global global_variations
1975    set status 0
1976    if {[require_portlist portlist]} {
1977        return 1
1978    }
1979
1980    set separator ""
1981    foreachport $portlist {
1982        set index_only 0
1983        if {[info exists options(ports_info_index)] && $options(ports_info_index)} {
1984            set index_only 1
1985        }
1986        puts -nonewline $separator
1987        array unset portinfo
1988        # If we have a url, use that, since it's most specific
1989        # otherwise try to map the portname to a url
1990        if {$porturl eq "" || $index_only} {
1991        # Verify the portname, getting portinfo to map to a porturl
1992            if {[catch {mportlookup $portname} result]} {
1993                ui_debug "$::errorInfo"
1994                break_softcontinue "lookup of portname $portname failed: $result" 1 status
1995            }
1996            if {[llength $result] < 2} {
1997                break_softcontinue "Port $portname not found" 1 status
1998            }
1999            array set portinfo [lindex $result 1]
2000            set porturl $portinfo(porturl)
2001            set portdir $portinfo(portdir)
2002        }
2003
2004        if {!$index_only} {
2005            # Add any global_variations to the variations
2006            # specified for the port (so we get e.g. dependencies right)
2007            array unset merged_variations
2008            array set merged_variations [array get variations]
2009            foreach { variation value } [array get global_variations] { 
2010                if { ![info exists merged_variations($variation)] } { 
2011                    set merged_variations($variation) $value 
2012                } 
2013            }
2014            if {![info exists options(subport)]} {
2015                if {[info exists portinfo(name)]} {
2016                    set options(subport) $portinfo(name)
2017                } else {
2018                    set options(subport) $portname
2019                }
2020            }
2021 
2022            if {[catch {set mport [mportopen $porturl [array get options] [array get merged_variations]]} result]} {
2023                ui_debug "$::errorInfo"
2024                break_softcontinue "Unable to open port: $result" 1 status
2025            }
2026            unset options(subport)
2027            array unset portinfo
2028            array set portinfo [mportinfo $mport]
2029            mportclose $mport
2030            if {[info exists portdir]} {
2031                set portinfo(portdir) $portdir
2032            }
2033        } elseif {![info exists portinfo]} {
2034            ui_warn "no PortIndex entry found for $portname"
2035            continue
2036        }
2037        array unset options ports_info_index
2038
2039        # Understand which info items are actually lists
2040        # (this could be overloaded to provide a generic formatting code to
2041        # allow us to, say, split off the prefix on libs)
2042        array set list_map "
2043            categories      1
2044            depends_fetch   1
2045            depends_extract 1
2046            depends_build   1
2047            depends_lib     1
2048            depends_run     1
2049            maintainers     1
2050            platforms       1
2051            variants        1
2052            conflicts       1
2053            subports        1
2054            patchfiles      1
2055        "
2056
2057        # Label map for pretty printing
2058        array set pretty_label {
2059            heading     ""
2060            variants    Variants
2061            depends_fetch "Fetch Dependencies"
2062            depends_extract "Extract Dependencies"
2063            depends_build "Build Dependencies"
2064            depends_run "Runtime Dependencies"
2065            depends_lib "Library Dependencies"
2066            description "Brief Description"
2067            long_description "Description"
2068            fullname    "Full Name: "
2069            homepage    Homepage
2070            platforms   Platforms
2071            maintainers Maintainers
2072            license     License
2073            conflicts   "Conflicts with"
2074            replaced_by "Replaced by"
2075            subports    "Sub-ports"
2076            patchfiles  "Patchfiles"
2077        }
2078
2079        # Wrap-length map for pretty printing
2080        array set pretty_wrap {
2081            heading 0
2082            replaced_by 22
2083            variants 22
2084            depends_fetch 22
2085            depends_extract 22
2086            depends_build 22
2087            depends_run 22
2088            depends_lib 22
2089            description 22
2090            long_description 22
2091            homepage 22
2092            platforms 22
2093            license 22
2094            conflicts 22
2095            maintainers 22
2096            subports 22
2097            patchfiles 22
2098        }
2099
2100        # Interpret a convenient field abbreviation
2101        if {[info exists options(ports_info_depends)] && $options(ports_info_depends) eq "yes"} {
2102            array unset options ports_info_depends
2103            set options(ports_info_depends_fetch) yes
2104            set options(ports_info_depends_extract) yes
2105            set options(ports_info_depends_build) yes
2106            set options(ports_info_depends_lib) yes
2107            set options(ports_info_depends_run) yes
2108        }
2109               
2110        # Set up our field separators
2111        set show_label 1
2112        set field_sep "\n"
2113        set subfield_sep ", "
2114        set pretty_print 0
2115       
2116        # For human-readable summary, which is the default with no options
2117        if {[llength [array get options ports_info_*]] == 0} {
2118            set pretty_print 1
2119        } elseif {[info exists options(ports_info_pretty)]} {
2120            set pretty_print 1
2121            array unset options ports_info_pretty
2122        }
2123
2124        # Tune for sort(1)
2125        if {[info exists options(ports_info_line)]} {
2126            array unset options ports_info_line
2127            set noseparator 1
2128            set show_label 0
2129            set field_sep "\t"
2130            set subfield_sep ","
2131        }
2132       
2133        # Figure out whether to show field name
2134        set quiet [macports::ui_isset ports_quiet]
2135        if {$quiet} {
2136            set show_label 0
2137        }
2138        # In pretty-print mode we also suppress messages, even though we show
2139        # most of the labels:
2140        if {$pretty_print} {
2141            set quiet 1
2142        }
2143
2144        # Spin through action options, emitting information for any found
2145        set fields {}
2146        set opts_todo [array names options ports_info_*]
2147        set fields_tried {}
2148        if {![llength $opts_todo]} {
2149            set opts_todo {ports_info_heading
2150                ports_info_replaced_by
2151                ports_info_subports
2152                ports_info_variants 
2153                ports_info_skip_line
2154                ports_info_long_description ports_info_homepage
2155                ports_info_skip_line ports_info_depends_fetch
2156                ports_info_depends_extract ports_info_depends_build
2157                ports_info_depends_lib ports_info_depends_run
2158                ports_info_conflicts
2159                ports_info_platforms ports_info_license
2160                ports_info_maintainers
2161            }
2162        }
2163        foreach { option } $opts_todo {
2164            set opt [string range $option 11 end]
2165            # Artificial field name for formatting
2166            if {$pretty_print && $opt eq "skip_line"} {
2167                lappend fields ""
2168                continue
2169            }
2170            # Artificial field names to reproduce prettyprinted summary
2171            if {$opt eq "heading"} {
2172                set inf "$portinfo(name) @$portinfo(version)"
2173                set ropt "heading"
2174                if {[info exists portinfo(revision)] && $portinfo(revision) > 0} {
2175                    append inf "_$portinfo(revision)"
2176                }
2177                if {[info exists portinfo(categories)]} {
2178                    append inf " ([join $portinfo(categories) ", "])"
2179                }
2180            } elseif {$opt eq "fullname"} {
2181                set inf "$portinfo(name) @"
2182                append inf [composite_version $portinfo(version) $portinfo(active_variants)]
2183                set ropt "fullname"
2184            } else {
2185                # Map from friendly name
2186                set ropt [map_friendly_field_names $opt]
2187               
2188                # If there's no such info, move on
2189                if {![info exists portinfo($ropt)]} {
2190                    set inf ""
2191                } else {
2192                    set inf [join $portinfo($ropt)]
2193                }
2194            }
2195
2196            # Calculate field label
2197            set label ""
2198            if {$pretty_print} {
2199                if {[info exists pretty_label($ropt)]} {
2200                    set label $pretty_label($ropt)
2201                } else {
2202                    set label $opt
2203                }
2204            } elseif {$show_label} {
2205                set label "$opt: "
2206            }
2207           
2208            # Format the data
2209            if { $ropt eq "maintainers" } {
2210                set inf [unobscure_maintainers $inf]
2211            }
2212            #     ... special formatting for certain fields when prettyprinting
2213            if {$pretty_print} {
2214                if {$ropt eq "variants"} {
2215                    # Use the new format for variants iff it exists in
2216                    # PortInfo. This key currently does not exist outside of
2217                    # trunk (1.8.0).
2218                    array unset vinfo
2219                    if {[info exists portinfo(vinfo)]} {
2220                        array set vinfo $portinfo(vinfo)
2221                    }
2222
2223                    set pi_vars $inf
2224                    set inf {}
2225                    foreach v [lsort $pi_vars] {
2226                        set varmodifier ""
2227                        if {[info exists variations($v)]} {
2228                            # selected by command line, prefixed with +/-
2229                            set varmodifier $variations($v)
2230                        } elseif {[info exists global_variations($v)]} {
2231                            # selected by variants.conf, prefixed with (+)/(-)
2232                            set varmodifier "($global_variations($v))"
2233                            # Retrieve additional information from the new key.
2234                        } elseif {[info exists vinfo]} {
2235                            array unset variant
2236                            array set variant $vinfo($v)
2237                            if {[info exists variant(is_default)]} {
2238                                set varmodifier "\[$variant(is_default)]"
2239                            }
2240                        }
2241                        lappend inf "$varmodifier$v"
2242                    }
2243                } elseif {[string match "depend*" $ropt] 
2244                          && ![macports::ui_isset ports_verbose]} {
2245                    set pi_deps $inf
2246                    set inf {}
2247                    foreach d $pi_deps {
2248                        lappend inf [lindex [split $d :] end]
2249                    }
2250                }
2251            } 
2252            #End of special pretty-print formatting for certain fields
2253            if {[info exists list_map($ropt)]} {
2254                set field [join $inf $subfield_sep]
2255            } else {
2256                set field $inf
2257            }
2258           
2259            # Assemble the entry
2260            if {$pretty_print} {
2261                # The two special fields are considered headings and are
2262                # emitted immediately, rather than waiting. Also they are not
2263                # recorded on the list of fields tried
2264                if {$ropt eq "heading" || $ropt eq "fullname"} {
2265                    puts "$label$field"
2266                    continue
2267                }
2268            }
2269            lappend fields_tried $label
2270            if {$pretty_print} {
2271                if {$field eq ""} {
2272                    continue
2273                }
2274                if {$label eq ""} {
2275                    set wrap_len 0
2276                    if {[info exists pretty_wrap($ropt)]} {
2277                        set wrap_len $pretty_wrap($ropt)
2278                    }
2279                    lappend fields [wrap $field 0 [string repeat " " $wrap_len]]
2280                } else {
2281                    set wrap_len [string length $label]
2282                    if {[info exists pretty_wrap($ropt)]} {
2283                        set wrap_len $pretty_wrap($ropt)
2284                    }
2285                    lappend fields [wraplabel $label $field 0 [string repeat " " $wrap_len]]
2286                }
2287
2288            } else { # Not pretty print
2289                lappend fields "$label$field"
2290            }
2291        }
2292
2293        # Now output all that information:
2294        if {[llength $fields]} {
2295            puts [join $fields $field_sep]
2296        } else {
2297            if {$pretty_print && [llength $fields_tried]} {
2298                puts -nonewline "$portinfo(name) has no "
2299                puts [join $fields_tried ", "]
2300            }
2301        }
2302        if {![info exists noseparator]} {
2303            set separator "--\n"
2304        }
2305    }
2306   
2307    return $status
2308}
2309
2310
2311proc action_location { action portlist opts } {
2312    set status 0
2313    if {[require_portlist portlist]} {
2314        return 1
2315    }
2316    foreachport $portlist {
2317        if { [catch {set ilist [registry_installed $portname [composite_version $portversion [array get variations]]]} result] } {
2318            global errorInfo
2319            ui_debug "$errorInfo"
2320            break_softcontinue "port location failed: $result" 1 status
2321        } else {
2322            # set portname again since the one we were passed may not have had the correct case
2323            set portname [lindex $ilist 0]
2324            set version [lindex $ilist 1]
2325            set revision [lindex $ilist 2]
2326            set variants [lindex $ilist 3]
2327            set epoch [lindex $ilist 5]
2328        }
2329
2330        set ref [registry::open_entry $portname $version $revision $variants $epoch]
2331        set imagedir [registry::property_retrieve $ref location]
2332        ui_notice "Port $portname ${version}_${revision}${variants} is installed as an image in:"
2333        puts $imagedir
2334    }
2335   
2336    return $status
2337}
2338
2339
2340proc action_notes { action portlist opts } {
2341    if {[require_portlist portlist]} {
2342        return 1
2343    }
2344
2345    set status 0
2346    foreachport $portlist {
2347        array unset portinfo
2348        if {$porturl eq ""} {
2349            # Look up the port.
2350            if {[catch {mportlookup $portname} result]} {
2351                ui_debug $::errorInfo
2352                break_softcontinue "The lookup of '$portname' failed: $result" \
2353                                1 status
2354            }
2355            if {[llength $result] < 2} {
2356                break_softcontinue "The port '$portname' was not found" 1 status
2357            }
2358
2359            # Retrieve the port's URL.
2360            array set portinfo [lindex $result 1]
2361            set porturl $portinfo(porturl)
2362        }
2363       
2364        # Add any global_variations to the variations
2365        # specified for the port
2366        array unset merged_variations
2367        array set merged_variations [array get variations]
2368        foreach { variation value } [array get global_variations] { 
2369            if { ![info exists merged_variations($variation)] } { 
2370                set merged_variations($variation) $value 
2371            } 
2372        }
2373        if {![info exists options(subport)]} {
2374            if {[info exists portinfo(name)]} {
2375                set options(subport) $portinfo(name)
2376            } else {
2377                set options(subport) $portname
2378            }
2379        }
2380
2381        # Open the Portfile associated with this port.
2382        if {[catch {set mport [mportopen $porturl [array get options] \
2383                                         [array get merged_variations]]} \
2384                   result]} {
2385            ui_debug $::errorInfo
2386            break_softcontinue [concat "The URL '$porturl' could not be" \
2387                                       "opened: $result"] 1 status
2388        }
2389        array unset portinfo
2390        array set portinfo [mportinfo $mport]
2391        mportclose $mport
2392
2393        # Return the notes associated with this Portfile.
2394        if {[info exists portinfo(notes)]} {
2395            set portnotes $portinfo(notes)
2396        } else {
2397            set portnotes {}
2398        }
2399
2400        # Retrieve the port's name once more to ensure it has the proper case.
2401        set portname $portinfo(name)
2402
2403        # Display the notes.
2404        if {$portnotes ne {}} {
2405            ui_notice "$portname has the following notes:"
2406            foreach note $portnotes {
2407                puts [wrap $note 0 "  " 1]
2408            }
2409        } else {
2410            puts "$portname has no notes."
2411        }
2412    }
2413    return $status
2414}
2415
2416
2417proc action_provides { action portlist opts } {
2418    # In this case, portname is going to be used for the filename... since
2419    # that is the first argument we expect... perhaps there is a better way
2420    # to do this?
2421    if { ![llength $portlist] } {
2422        ui_error "Please specify a filename to check which port provides that file."
2423        return 1
2424    }
2425    foreach filename $portlist {
2426        set file [file normalize $filename]
2427        if {[file exists $file] || ![catch {file type $file}]} {
2428            if {![file isdirectory $file] || [file type $file] eq "link"} {
2429                set port [registry::file_registered $file]
2430                if { $port != 0 } {
2431                    puts "$file is provided by: $port"
2432                } else {
2433                    puts "$file is not provided by a MacPorts port."
2434                }
2435            } else {
2436                puts "$file is a directory."
2437            }
2438        } else {
2439            puts "$file does not exist."
2440        }
2441    }
2442    registry::close_file_map
2443   
2444    return 0
2445}
2446
2447
2448proc action_activate { action portlist opts } {
2449    set status 0
2450    if {[require_portlist portlist] || [prefix_unwritable]} {
2451        return 1
2452    }
2453    foreachport $portlist {
2454        set composite_version [composite_version $portversion [array get variations]]
2455        if {![info exists options(ports_activate_no-exec)]
2456            && ![catch {set ilist [registry::installed $portname $composite_version]}]
2457            && [llength $ilist] == 1} {
2458
2459            set i [lindex $ilist 0]
2460            set regref [registry::entry open $portname [lindex $i 1] [lindex $i 2] [lindex $i 3] [lindex $i 5]]
2461            if {[$regref installtype] eq "image" && [registry::run_target $regref activate [array get options]]} {
2462                continue
2463            }
2464        }
2465        if {![macports::global_option_isset ports_dryrun]} {
2466            if { [catch {portimage::activate_composite $portname $composite_version [array get options]} result] } {
2467                global errorInfo
2468                ui_debug "$errorInfo"
2469                break_softcontinue "port activate failed: $result" 1 status
2470            }
2471        } else {
2472            ui_msg "Skipping activate $portname (dry run)"
2473        }
2474    }
2475   
2476    return $status
2477}
2478
2479
2480proc action_deactivate { action portlist opts } {
2481    set status 0
2482    if {[require_portlist portlist] || [prefix_unwritable]} {
2483        return 1
2484    }
2485    set portlist [portlist_sortdependents $portlist]
2486    foreachport $portlist {
2487        set composite_version [composite_version $portversion [array get variations]]
2488        if {![info exists options(ports_deactivate_no-exec)]
2489            && ![catch {set ilist [registry::active $portname]}]} {
2490
2491            set i [lindex $ilist 0]
2492            set iversion [lindex $i 1]
2493            set irevision [lindex $i 2]
2494            set ivariants [lindex $i 3]
2495            if {$composite_version eq "" || $composite_version == "${iversion}_${irevision}${ivariants}"} {
2496                set regref [registry::entry open $portname $iversion $irevision $ivariants [lindex $i 5]]
2497                if {[$regref installtype] eq "image" && [registry::run_target $regref deactivate [array get options]]} {
2498                    continue
2499                }
2500            }
2501        }
2502        if {![macports::global_option_isset ports_dryrun]} {
2503            if { [catch {portimage::deactivate_composite $portname $composite_version [array get options]} result] } {
2504                global errorInfo
2505                ui_debug "$errorInfo"
2506                break_softcontinue "port deactivate failed: $result" 1 status
2507            }
2508        } else {
2509            ui_msg "Skipping deactivate $portname (dry run)"
2510        }
2511    }
2512   
2513    return $status
2514}
2515
2516
2517proc action_select { action portlist opts } {
2518    ui_debug "action_select \[$portlist] \[$opts]..."
2519
2520    array set opts_array $opts
2521    set commands [array names opts_array ports_select_*]
2522    array unset opts_array
2523
2524    # Error out if no group is specified or command is not --summary.
2525    if {[llength $portlist] < 1 && [string map {ports_select_ ""} [lindex $commands 0]] != "summary"} {
2526        ui_error "Incorrect usage. Correct synopsis is one of:"
2527        ui_msg   "  port select \[--list|--show\] <group>"
2528        ui_msg   "  port select \[--set\] <group> <version>"
2529        ui_msg   "  port select --summary"
2530        return 1
2531    }
2532
2533    set group [lindex $portlist 0]
2534   
2535    # If no command (--set, --show, --list, --summary) is specified *but*
2536    #  more than one argument is specified, default to the set command.
2537    if {[llength $commands] < 1 && [llength $portlist] > 1} {
2538        set command set
2539        ui_debug [concat "Although no command was specified, more than " \
2540                         "one argument was specified.  Defaulting to the " \
2541                         "'set' command..."]
2542    # If no command (--set, --show, --list) is specified *and* less than two
2543    # argument are specified, default to the list command.
2544    } elseif {[llength $commands] < 1} {
2545        set command list
2546        ui_debug [concat "No command was specified. Defaulting to the " \
2547                         "'list' command..."]
2548    # Only allow one command to be specified at a time.
2549    } elseif {[llength $commands] > 1} {
2550        ui_error [concat "Multiple commands were specified. Only one " \
2551                         "command may be specified at a time."]
2552        return 1
2553    } else {
2554        set command [string map {ports_select_ ""} [lindex $commands 0]]
2555        ui_debug "The '$command' command was specified."
2556    }
2557
2558    switch -- $command {
2559        list {
2560            if {[llength $portlist] > 1} {
2561                ui_warn [concat "The 'list' command does not expect any " \
2562                                "arguments. Extra arguments will be ignored."]
2563            }
2564
2565            if {[catch {mportselect show $group} selected_version]} {
2566                global errorInfo
2567                ui_debug $errorInfo
2568                ui_warn "Unable to get active selected version: $selected_version"
2569            }
2570
2571            # On error mportselect returns with the code 'error'.
2572            if {[catch {mportselect $command $group} versions]} {
2573                ui_error "The 'list' command failed: $versions"
2574                return 1
2575            }
2576
2577            ui_notice "Available versions for $group:"
2578            foreach v $versions {
2579                ui_notice -nonewline "\t"
2580                if {$selected_version == $v} {
2581                    ui_msg "$v (active)"
2582                } else {
2583                    ui_msg "$v"
2584                }
2585            }
2586            return 0
2587        }
2588        set {
2589            if {[llength $portlist] < 2} {
2590                ui_error [concat "The 'set' command expects two " \
2591                                 "arguments: <group>, <version>"]
2592                return 1
2593            } elseif {[llength $portlist] > 2} {
2594                ui_warn [concat "The 'set' command only expects two " \
2595                                "arguments. Extra arguments will be " \
2596                                "ignored."]
2597            }
2598            set version [lindex $portlist 1]
2599
2600            ui_msg -nonewline "Selecting '$version' for '$group' "
2601            if {[catch {mportselect $command $group $version} result]} {
2602                ui_msg "failed: $result"
2603                return 1
2604            }
2605            ui_msg "succeeded. '$version' is now active."
2606            return 0
2607        }
2608        show {
2609            if {[llength $portlist] > 1} {
2610                ui_warn [concat "The 'show' command does not expect any " \
2611                                "arguments. Extra arguments will be ignored."]
2612            }
2613
2614            if {[catch {mportselect $command $group} selected_version]} {
2615                ui_error "The 'show' command failed: $selected_version"
2616                return 1
2617            }
2618            puts [concat "The currently selected version for '$group' is " \
2619                         "'$selected_version'."]
2620            return 0
2621        }
2622        summary {
2623            if {[llength $portlist] > 0} {
2624                ui_warn [concat "The 'summary' command does not expect any " \
2625                                "arguments. Extra arguments will be ignored."]
2626            }
2627
2628            if {[catch {mportselect $command} portgroups]} {
2629                ui_error "The 'summary' command failed: $portgroups"
2630                return 1
2631            }
2632
2633            set w1 4
2634            set w2 8
2635            set formatStr "%-*s  %-*s  %s"
2636
2637            set groups [list]
2638            foreach pg $portgroups {
2639                array set groupdesc {}
2640                set groupdesc(name) [string trim $pg]
2641
2642                if {[catch {mportselect list $pg} versions]} {
2643                    ui_warn "The list of options for the select group $pg could not be obtained: $versions"
2644                    continue
2645                }
2646                # remove "none", sort the list, append none at the end
2647                set noneidx [lsearch -exact $versions "none"]
2648                set versions [lsort [lreplace $versions $noneidx $noneidx]]
2649                lappend versions "none"
2650                set groupdesc(versions) $versions
2651
2652                if {[catch {mportselect show $pg} selected_version]} {
2653                    ui_warn "The currently selected option for the select group $pg could not be obtained: $selected_version"
2654                    continue
2655                }
2656                set groupdesc(selected) $selected_version
2657
2658                set w1 [expr {max($w1, [string length $pg])}]
2659                set w2 [expr {max($w2, [string length $selected_version])}]
2660
2661                lappend groups [array get groupdesc]
2662                array unset groupdesc
2663            }
2664            puts [format $formatStr $w1 "Name" $w2 "Selected" "Options"]
2665            puts [format $formatStr $w1 "====" $w2 "========" "======="]
2666            foreach groupdesc $groups {
2667                array set groupd $groupdesc
2668                puts [format $formatStr $w1 $groupd(name) $w2 $groupd(selected) [join $groupd(versions) " "]]
2669                array unset groupd
2670            }
2671            return 0
2672        }
2673        default {
2674            ui_error "An unknown command '$command' was specified."
2675            return 1
2676        }
2677    }
2678}
2679
2680
2681proc action_selfupdate { action portlist opts } {
2682    global global_options
2683    if { [catch {macports::selfupdate [array get global_options] base_updated} result ] } {
2684        global errorInfo
2685        ui_debug "$errorInfo"
2686        ui_error "$result"
2687        if {![macports::ui_isset ports_verbose]} {
2688            ui_msg "Please run `port -v selfupdate' for details."
2689        } else {
2690            # Let's only print the ticket URL if the user has followed the
2691            # advice we printed earlier.
2692            print_tickets_url
2693        }
2694        fatal "port selfupdate failed: $result"
2695    }
2696   
2697    if {$base_updated} {
2698        # exit immediately if in batch/interactive mode
2699        return -999
2700    } else {
2701        return 0
2702    }
2703}
2704
2705
2706proc action_setrequested { action portlist opts } {
2707    set status 0
2708    if {[require_portlist portlist] || [prefix_unwritable]} {
2709        return 1
2710    }
2711    # set or unset?
2712    set val [string equal $action "setrequested"]
2713    foreachport $portlist {
2714        set composite_version [composite_version $portversion [array get variations]]
2715        if {![catch {set ilist [registry::installed $portname $composite_version]} result]} {
2716            ui_info "Setting requested flag for $portname to $val"
2717            foreach i $ilist {
2718                set regref [registry::open_entry $portname [lindex $i 1] [lindex $i 2] [lindex $i 3] [lindex $i 5]]
2719                registry::property_store $regref requested $val
2720            }
2721        } else {
2722            global errorInfo
2723            ui_debug "$errorInfo"
2724            break_softcontinue "$result" 1 status
2725        }
2726    }
2727   
2728    return $status
2729}
2730
2731proc action_diagnose { action portlist opts } {
2732    if {[prefix_unwritable]} {
2733        return 1
2734    }
2735    macports::diagnose_main $opts
2736    return 0
2737}
2738
2739proc action_reclaim { action portlist opts } {
2740    if {[prefix_unwritable]} {
2741        return 1
2742    }
2743    macports::reclaim_main 
2744    return 0
2745}
2746
2747
2748proc action_upgrade { action portlist opts } {
2749    if {[require_portlist portlist "yes"] || ([prefix_unwritable] && ![macports::global_option_isset ports_dryrun])} {
2750        return 1
2751    }
2752
2753    # shared depscache for all ports in the list
2754    array set depscache {}
2755    set status 0
2756    foreachport $portlist {
2757        if {![info exists depscache(port:$portname)]} {
2758            set status [macports::upgrade $portname "port:$portname" [array get requested_variations] [array get options] depscache]
2759            # status 2 means the port was not found in the index,
2760            # status 3 means the port is not installed
2761            if {$status != 0 && $status != 2 && $status != 3 && ![macports::ui_isset ports_processall]} {
2762                break
2763            }
2764        }
2765    }
2766   
2767    if {$status != 0 && $status != 2 && $status != 3} {
2768        print_tickets_url
2769    } elseif {$status == 0} {
2770        array set options $opts
2771        if {![info exists options(ports_upgrade_no-rev-upgrade)] && ${macports::revupgrade_autorun} && ![macports::global_option_isset ports_dryrun]} {
2772            set status [action_revupgrade $action $portlist $opts]
2773        }
2774    }
2775
2776    return $status
2777}
2778
2779proc action_revupgrade { action portlist opts } {
2780    set status [macports::revupgrade $opts]
2781    switch $status {
2782        1 {
2783            print_tickets_url
2784        }
2785    }
2786
2787    return $status
2788}
2789
2790
2791proc action_version { action portlist opts } {
2792    if {![macports::ui_isset ports_quiet]} {
2793        puts -nonewline "Version: "
2794    }
2795    puts [macports::version]
2796    return 0
2797}
2798
2799
2800proc action_platform { action portlist opts } {
2801    if {![macports::ui_isset ports_quiet]} {
2802        puts -nonewline "Platform: "
2803    }
2804    puts "${macports::os_platform} ${macports::os_major} ${macports::os_arch}"
2805    return 0
2806}
2807
2808
2809proc action_dependents { action portlist opts } {
2810    if {[require_portlist portlist]} {
2811        return 1
2812    }
2813    set ilist {}
2814
2815    registry::open_dep_map
2816
2817    set status 0
2818    foreachport $portlist {
2819        set composite_version [composite_version $portversion [array get variations]]
2820        if { [catch {set ilist [registry::installed $portname $composite_version]} result] } {
2821            global errorInfo
2822            ui_debug "$errorInfo"
2823            break_softcontinue "$result" 1 status
2824        } else {
2825            # choose the active version if there is one
2826            set index 0
2827            foreach i $ilist {
2828                if {[lindex $i 4]} {
2829                    set found 1
2830                    break
2831                }
2832                incr index
2833            }
2834            if {![info exists found]} {
2835                set index 0
2836            }
2837            # set portname again since the one we were passed may not have had the correct case
2838            set portname [lindex $ilist $index 0]
2839            set iversion [lindex $ilist $index 1]
2840            set irevision [lindex $ilist $index 2]
2841            set ivariants [lindex $ilist $index 3]
2842        }
2843       
2844        set deplist [registry::list_dependents $portname $iversion $irevision $ivariants]
2845        if { [llength $deplist] > 0 } {
2846            if {$action eq "rdependents"} {
2847                set toplist $deplist
2848                while 1 {
2849                    set newlist {}
2850                    foreach dep $deplist {
2851                        set depname [lindex $dep 2]
2852                        if {![info exists seen($depname)]} {
2853                            set seen($depname) 1
2854                            set rdeplist [registry::list_dependents $depname]
2855                            foreach rdep $rdeplist {
2856                                lappend newlist $rdep
2857                            }
2858                            set dependentsof($depname) $rdeplist
2859                        }
2860                    }
2861                    if {[llength $newlist] > 0} {
2862                        set deplist $newlist
2863                    } else {
2864                        break
2865                    }
2866                }
2867                set portstack [list $toplist]
2868                set pos_stack [list 0]
2869                array unset seen
2870                ui_notice "The following ports are dependent on ${portname}:"
2871                while 1 {
2872                    set cur_portlist [lindex $portstack end]
2873                    set cur_pos [lindex $pos_stack end]
2874                    if {$cur_pos >= [llength $cur_portlist]} {
2875                        set portstack [lreplace $portstack end end]
2876                        set pos_stack [lreplace $pos_stack end end]
2877                        if {[llength $portstack] <= 0} {
2878                            break
2879                        } else {
2880                            continue
2881                        }
2882                    }
2883                    set cur_port [lindex $cur_portlist $cur_pos]
2884                    set cur_portname [lindex $cur_port 2]
2885                    set spaces [string repeat " " [expr {[llength $pos_stack] * 2}]]
2886                    if {![info exists seen($cur_portname)] || ([info exists options(ports_rdependents_full)] && [string is true -strict $options(ports_rdependents_full)])} {
2887                        puts "${spaces}${cur_portname}"
2888                        set seen($cur_portname) 1
2889                        incr cur_pos
2890                        set pos_stack [lreplace $pos_stack end end $cur_pos]
2891                        if {[info exists dependentsof($cur_portname)]} {
2892                            lappend portstack $dependentsof($cur_portname)
2893                            lappend pos_stack 0
2894                        }
2895                        continue
2896                    }
2897                    incr cur_pos
2898                    set pos_stack [lreplace $pos_stack end end $cur_pos]
2899                }
2900            } else {
2901                foreach dep $deplist {
2902                    set depport [lindex $dep 2]
2903                    if {[macports::ui_isset ports_quiet]} {
2904                        ui_msg "$depport"
2905                    } elseif {![macports::ui_isset ports_verbose]} {
2906                        ui_msg "$depport depends on $portname"
2907                    } else {
2908                        ui_msg "$depport depends on $portname (by [lindex $dep 1]:)"
2909                    }
2910                }
2911            }
2912        } else {
2913            ui_notice "$portname has no dependents."
2914        }
2915    }
2916    return $status
2917}
2918
2919
2920proc action_deps { action portlist opts } {
2921    global global_variations
2922    set status 0
2923    if {[require_portlist portlist]} {
2924        return 1
2925    }
2926    set separator ""
2927
2928    foreachport $portlist {
2929        if {[info exists options(ports_${action}_no-build)] && [string is true -strict $options(ports_${action}_no-build)]} {
2930            set deptypes {depends_lib depends_run}
2931        } else {
2932            set deptypes {depends_fetch depends_extract depends_build depends_lib depends_run}
2933        }
2934
2935        array unset portinfo
2936        # If we have a url, use that, since it's most specific
2937        # otherwise try to map the portname to a url
2938        if {$porturl eq ""} {
2939        # Verify the portname, getting portinfo to map to a porturl
2940            if {[catch {mportlookup $portname} result]} {
2941                ui_debug "$::errorInfo"
2942                break_softcontinue "lookup of portname $portname failed: $result" 1 status
2943            }
2944            if {[llength $result] < 2} {
2945                break_softcontinue "Port $portname not found" 1 status
2946            }
2947            array set portinfo [lindex $result 1]
2948            set porturl $portinfo(porturl)
2949        } elseif {$porturl ne "file://."} {
2950            # Extract the portdir from porturl and use it to search PortIndex.
2951            # Only the last two elements of the path (porturl) make up the
2952            # portdir.
2953            set portdir [file split [macports::getportdir $porturl]]
2954            set lsize [llength $portdir]
2955            set portdir \
2956                [file join [lindex $portdir [expr {$lsize - 2}]] \
2957                           [lindex $portdir [expr {$lsize - 1}]]]
2958            if {[catch {mportsearch $portdir no exact portdir} result]} {
2959                ui_debug "$::errorInfo"
2960                break_softcontinue "Portdir $portdir not found" 1 status
2961            }
2962            if {[llength $result] < 2} {
2963                break_softcontinue "Portdir $portdir not found" 1 status
2964            }
2965            set matchindex [lsearch -exact -nocase $result $portname]
2966            if {$matchindex != -1} {
2967                array set portinfo [lindex $result [incr matchindex]]
2968            } else {
2969                ui_warn "Portdir $portdir doesn't seem to belong to portname $portname"
2970                array set portinfo [lindex $result 1]
2971            }
2972        }
2973
2974        if {!([info exists options(ports_${action}_index)] && $options(ports_${action}_index) eq "yes")} {
2975            # Add any global_variations to the variations
2976            # specified for the port, so we get dependencies right
2977            array unset merged_variations
2978            array set merged_variations [array get variations]
2979            foreach { variation value } [array get global_variations] { 
2980                if { ![info exists merged_variations($variation)] } { 
2981                    set merged_variations($variation) $value 
2982                } 
2983            }
2984            if {![info exists options(subport)]} {
2985                if {[info exists portinfo(name)]} {
2986                    set options(subport) $portinfo(name)
2987                } else {
2988                    set options(subport) $portname
2989                }
2990            }
2991            if {[catch {set mport [mportopen $porturl [array get options] [array get merged_variations]]} result]} {
2992                ui_debug "$::errorInfo"
2993                break_softcontinue "Unable to open port: $result" 1 status
2994            }
2995            array unset portinfo
2996            array set portinfo [mportinfo $mport]
2997            mportclose $mport
2998        } elseif {![info exists portinfo]} {
2999            ui_warn "port ${action} --index does not work with the 'current' pseudo-port"
3000            continue
3001        }
3002        set portname $portinfo(name)
3003
3004        set deplist {}
3005        set deps_output {}
3006        set ndeps 0
3007        array set labeldict {depends_fetch Fetch depends_extract Extract depends_build Build depends_lib Library depends_run Runtime}
3008        # get list of direct deps
3009        foreach type $deptypes {
3010            if {[info exists portinfo($type)]} {
3011                if {$action eq "rdeps" || [macports::ui_isset ports_verbose]} {
3012                    foreach dep $portinfo($type) {
3013                        lappend deplist $dep
3014                    }
3015                } else {
3016                    foreach dep $portinfo($type) {
3017                        lappend deplist [lindex [split $dep :] end]
3018                    }
3019                }
3020                if {$action eq "deps"} {
3021                    set label "$labeldict($type) Dependencies"
3022                    lappend deps_output [wraplabel $label [join $deplist ", "] 0 [string repeat " " 22]]
3023                    incr ndeps [llength $deplist]
3024                    set deplist {}
3025                }
3026            }
3027        }
3028
3029        set version $portinfo(version)
3030        set revision $portinfo(revision)
3031        if {[info exists portinfo(canonical_active_variants)]} {
3032            set variants $portinfo(canonical_active_variants)
3033        } else {
3034            set variants {}
3035        }
3036
3037        puts -nonewline $separator
3038        if {$action eq "deps"} {
3039            if {$ndeps == 0} {
3040                ui_notice "$portname @${version}_${revision}${variants} has no dependencies."
3041            } else {
3042                ui_notice "Full Name: $portname @${version}_${revision}${variants}"
3043                puts [join $deps_output "\n"]
3044            }
3045            set separator "--\n"
3046            continue
3047        }
3048
3049        set toplist $deplist
3050        # gather all the deps
3051        while 1 {
3052            set newlist {}
3053            foreach dep $deplist {
3054                set depname [lindex [split $dep :] end]
3055                if {![info exists seen($depname)]} {
3056                    set seen($depname) 1
3057                   
3058                    # look up the dep
3059                    if {[catch {mportlookup $depname} result]} {
3060                        ui_debug "$::errorInfo"
3061                        break_softcontinue "lookup of portname $depname failed: $result" 1 status
3062                    }
3063                    if {[llength $result] < 2} {
3064                        break_softcontinue "Port $depname not found" 1 status
3065                    }
3066                    array unset portinfo
3067                    array set portinfo [lindex $result 1]
3068                    set porturl $portinfo(porturl)
3069                    set options(subport) $portinfo(name)
3070                   
3071                    # open the portfile if requested
3072                    if {!([info exists options(ports_${action}_index)] && $options(ports_${action}_index) eq "yes")} {
3073                        if {[catch {set mport [mportopen $porturl [array get options] [array get merged_variations]]} result]} {
3074                            ui_debug "$::errorInfo"
3075                            break_softcontinue "Unable to open port: $result" 1 status
3076                        }
3077                        array unset portinfo
3078                        array set portinfo [mportinfo $mport]
3079                        mportclose $mport
3080                    }
3081                   
3082                    # get list of the dep's deps
3083                    set rdeplist {}
3084                    foreach type $deptypes {
3085                        if {[info exists portinfo($type)]} {
3086                            foreach rdep $portinfo($type) {
3087                                lappend rdeplist $rdep
3088                                lappend newlist $rdep
3089                            }
3090                        }
3091                    }
3092                    set depsof($depname) $rdeplist
3093                }
3094            }
3095            if {[llength $newlist] > 0} {
3096                set deplist $newlist
3097            } else {
3098                break
3099            }
3100        }
3101        set portstack [list $toplist]
3102        set pos_stack [list 0]
3103        array unset seen
3104        if {[llength $toplist] > 0} {
3105            ui_notice "The following ports are dependencies of $portname @${version}_${revision}${variants}:"
3106        } else {
3107            ui_notice "$portname @${version}_${revision}${variants} has no dependencies."
3108        }
3109        while 1 {
3110            set cur_portlist [lindex $portstack end]
3111            set cur_pos [lindex $pos_stack end]
3112            if {$cur_pos >= [llength $cur_portlist]} {
3113                set portstack [lreplace $portstack end end]
3114                set pos_stack [lreplace $pos_stack end end]
3115                if {[llength $portstack] <= 0} {
3116                    break
3117                } else {
3118                    continue
3119                }
3120            }
3121            set cur_port [lindex $cur_portlist $cur_pos]
3122            set cur_portname [lindex [split $cur_port :] end]
3123            set spaces [string repeat " " [expr {[llength $pos_stack] * 2}]]
3124            if {![info exists seen($cur_portname)] || ([info exists options(ports_${action}_full)] && [string is true -strict $options(ports_${action}_full)])} {
3125                if {[macports::ui_isset ports_verbose]} {
3126                    puts "${spaces}${cur_port}"
3127                } else {
3128                    puts "${spaces}${cur_portname}"
3129                }
3130                set seen($cur_portname) 1
3131                incr cur_pos
3132                set pos_stack [lreplace $pos_stack end end $cur_pos]
3133                if {[info exists depsof($cur_portname)]} {
3134                    lappend portstack $depsof($cur_portname)
3135                    lappend pos_stack 0
3136                }
3137                continue
3138            }
3139            incr cur_pos
3140            set pos_stack [lreplace $pos_stack end end $cur_pos]
3141        }
3142        set separator "--\n"
3143    }
3144    return $status
3145}
3146
3147
3148proc action_uninstall { action portlist opts } {
3149    set status 0
3150    if {[macports::global_option_isset port_uninstall_old]} {
3151        # if -u then uninstall all inactive ports
3152        # (union these to any other ports user has in the port list)
3153        set portlist [opUnion $portlist [get_inactive_ports]]
3154    } else {
3155        # Otherwise the user hopefully supplied a portlist, or we'll default to the existing directory
3156        if {[require_portlist portlist]} {
3157            return 1
3158        }
3159    }
3160    if {[prefix_unwritable]} {
3161        return 1
3162    }
3163
3164    set portlist [portlist_sortdependents $portlist]
3165
3166    foreachport $portlist {
3167        if {![registry::entry_exists_for_name $portname]} {
3168            # if the code path arrives here the port either isn't installed, or
3169            # it doesn't exist at all. We can't be sure, but we can check the
3170            # portindex whether a port by that name exists (in which case not
3171            # uninstalling it is probably no problem). If there is no port by
3172            # that name, alert the user in case of typos.
3173            ui_info "$portname is not installed"
3174            if {[catch {set res [mportlookup $portname]} result] || [llength $res] == 0} {
3175                ui_warn "no such port: $portname, skipping uninstall"
3176            }
3177            continue
3178        }
3179        set composite_version [composite_version $portversion [array get variations]]
3180        if {![info exists options(ports_uninstall_no-exec)]
3181            && ![catch {set ilist [registry::installed $portname $composite_version]}]
3182            && [llength $ilist] == 1} {
3183
3184            set i [lindex $ilist 0]
3185            set iactive [lindex $i 4]
3186            set regref [registry::entry open $portname [lindex $i 1] [lindex $i 2] [lindex $i 3] [lindex $i 5]]
3187            if {[registry::run_target $regref uninstall [array get options]]} {
3188                continue
3189            }
3190        }
3191
3192        if { [catch {registry_uninstall::uninstall_composite $portname $composite_version [array get options]} result] } {
3193            global errorInfo
3194            ui_debug "$errorInfo"
3195            break_softcontinue "port uninstall failed: $result" 1 status
3196        }
3197    }
3198
3199    return $status
3200}
3201
3202
3203proc action_installed { action portlist opts } {
3204    global private_options
3205    set status 0
3206    set restrictedList 0
3207    set ilist {}
3208   
3209    if { [llength $portlist] || (![info exists private_options(ports_no_args)] || $private_options(ports_no_args) eq "no")} {
3210        set restrictedList 1
3211        foreachport $portlist {
3212            set composite_version [composite_version $portversion [array get variations]]
3213            if { [catch {set ilist [concat $ilist [registry::installed $portname $composite_version]]} result] } {
3214                if {![string match "* not registered as installed." $result]} {
3215                    global errorInfo
3216                    ui_debug "$errorInfo"
3217                    break_softcontinue "port installed failed: $result" 1 status
3218                }
3219            }
3220        }
3221    } else {
3222        if { [catch {set ilist [registry::installed]} result] } {
3223            if {$result ne "Registry error: No ports registered as installed."} {
3224                global errorInfo
3225                ui_debug "$errorInfo"
3226                ui_error "port installed failed: $result"
3227                set status 1
3228            }
3229        }
3230    }
3231    if { [llength $ilist] > 0 } {
3232        ui_notice "The following ports are currently installed:"
3233        foreach i [portlist_sortint $ilist] {
3234            set iname [lindex $i 0]
3235            set iversion [lindex $i 1]
3236            set irevision [lindex $i 2]
3237            set ivariants [lindex $i 3]
3238            set iactive [lindex $i 4]
3239            set extra ""
3240            set nvariants ""
3241            if {[macports::ui_isset ports_verbose]} {
3242                set regref [registry::open_entry $iname $iversion $irevision $ivariants [lindex $i 5]]
3243                set nvariants [registry::property_retrieve $regref negated_variants]
3244                if {$nvariants == 0} {
3245                    set nvariants ""
3246                }
3247                set os_platform [registry::property_retrieve $regref os_platform]
3248                set os_major [registry::property_retrieve $regref os_major]
3249                set archs [registry::property_retrieve $regref archs]
3250                if {$os_platform != 0 && $os_platform ne "" && $os_major != 0 && $os_major ne ""} {
3251                    append extra " platform='$os_platform $os_major'"
3252                }
3253                if {$archs != 0 && $archs ne ""} {
3254                    append extra " archs='$archs'"
3255                }
3256            }
3257            if { $iactive == 0 } {
3258                puts "  $iname @${iversion}_${irevision}${ivariants}${nvariants}${extra}"
3259            } elseif { $iactive == 1 } {
3260                puts "  $iname @${iversion}_${irevision}${ivariants}${nvariants} (active)${extra}"
3261            }
3262        }
3263    } elseif { $restrictedList } {
3264        ui_notice "None of the specified ports are installed."
3265    } else {
3266        ui_notice "No ports are installed."
3267    }
3268
3269    return $status
3270}
3271
3272
3273proc action_outdated { action portlist opts } {
3274    global private_options
3275    set status 0
3276
3277    # If port names were supplied, limit ourselves to those ports, else check all installed ports
3278    set ilist {}
3279    set restrictedList 0
3280    if { [llength $portlist] || (![info exists private_options(ports_no_args)] || $private_options(ports_no_args) eq "no")} {
3281        set restrictedList 1
3282        foreach portspec $portlist {
3283            array set port $portspec
3284            set portname $port(name)
3285            set composite_version [composite_version $port(version) $port(variants)]
3286            if { [catch {set ilist [concat $ilist [registry::installed $portname $composite_version]]} result] } {
3287                if {![string match "* not registered as installed." $result]} {
3288                    global errorInfo
3289                    ui_debug "$errorInfo"
3290                    break_softcontinue "port outdated failed: $result" 1 status
3291                }
3292            }
3293        }
3294    } else {
3295        if { [catch {set ilist [registry::installed]} result] } {
3296            if {$result ne "Registry error: No ports registered as installed."} {
3297                global errorInfo
3298                ui_debug "$errorInfo"
3299                ui_error "port installed failed: $result"
3300                set status 1
3301            }
3302        }
3303    }
3304
3305    set num_outdated 0
3306    if { [llength $ilist] > 0 } {
3307        foreach i [portlist_sortint $ilist] {
3308       
3309            # Get information about the installed port
3310            set portname [lindex $i 0]
3311            set installed_version [lindex $i 1]
3312            set installed_revision [lindex $i 2]
3313            set installed_compound "${installed_version}_${installed_revision}"
3314
3315            set is_active [lindex $i 4]
3316            if {$is_active == 0} {
3317                continue
3318            }
3319            set installed_epoch [lindex $i 5]
3320
3321            # Get info about the port from the index
3322            if {[catch {set res [mportlookup $portname]} result]} {
3323                global errorInfo
3324                ui_debug "$errorInfo"
3325                break_softcontinue "search for portname $portname failed: $result" 1 status
3326            }
3327            if {[llength $res] < 2} {
3328                if {[macports::ui_isset ports_debug]} {
3329                    puts "$portname ($installed_compound is installed; the port was not found in the port index)"
3330                }
3331                continue
3332            }
3333            array unset portinfo
3334            array set portinfo [lindex $res 1]
3335           
3336            # Get information about latest available version and revision
3337            if {![info exists portinfo(version)]} {
3338                ui_warn "$portname has no version field"
3339                continue
3340            }
3341            set latest_version $portinfo(version)
3342            set latest_revision 0
3343            if {[info exists portinfo(revision)] && $portinfo(revision) > 0} { 
3344                set latest_revision $portinfo(revision)
3345            }
3346            set latest_compound "${latest_version}_${latest_revision}"
3347            set latest_epoch 0
3348            if {[info exists portinfo(epoch)]} { 
3349                set latest_epoch $portinfo(epoch)
3350            }
3351           
3352            # Compare versions, first checking epoch, then version, then revision
3353            set epoch_comp_result [expr {$installed_epoch - $latest_epoch}]
3354            set comp_result [vercmp $installed_version $latest_version]
3355            if { $comp_result == 0 } {
3356                set comp_result [expr {$installed_revision - $latest_revision}]
3357            }
3358            set reason ""
3359            if {$epoch_comp_result != 0 && $installed_version != $latest_version} {
3360                if {($comp_result >= 0 && $epoch_comp_result < 0) || ($comp_result <= 0 && $epoch_comp_result > 0)} {
3361                    set reason { (epoch $installed_epoch $relation $latest_epoch)}
3362                }
3363                set comp_result $epoch_comp_result
3364            } elseif {$comp_result == 0} {
3365                set regref [registry::open_entry $portname $installed_version $installed_revision [lindex $i 3] $installed_epoch]
3366                set os_platform_installed [registry::property_retrieve $regref os_platform]
3367                set os_major_installed [registry::property_retrieve $regref os_major]
3368                if {$os_platform_installed ne "" && $os_platform_installed != 0
3369                    && $os_major_installed ne "" && $os_major_installed != 0
3370                    && ($os_platform_installed != ${macports::os_platform} || $os_major_installed != ${macports::os_major})} {
3371                    set comp_result -1
3372                    set reason { (platform $os_platform_installed $os_major_installed != ${macports::os_platform} ${macports::os_major})}
3373                }
3374            }
3375           
3376            # Report outdated (or, for verbose, predated) versions
3377            if { $comp_result != 0 } {
3378                           
3379                # Form a relation between the versions
3380                set flag ""
3381                if { $comp_result > 0 } {
3382                    set relation ">"
3383                    set flag "!"
3384                } else {
3385                    set relation "<"
3386                }
3387               
3388                # Emit information
3389                if {$comp_result < 0 || [macports::ui_isset ports_verbose]} {
3390               
3391                    if {$num_outdated == 0} {
3392                        ui_notice "The following installed ports are outdated:"
3393                    }
3394                    incr num_outdated
3395
3396                    puts [format "%-30s %-24s %1s" $portname "$installed_compound $relation $latest_compound [subst $reason]" $flag]
3397                }
3398               
3399            }
3400        }
3401       
3402        if {$num_outdated == 0} {
3403            ui_notice "No installed ports are outdated."
3404        }
3405    } elseif { $restrictedList } {
3406        ui_notice "None of the specified ports are outdated."
3407    } else {
3408        ui_notice "No ports are installed."
3409    }
3410   
3411    return $status
3412}
3413
3414
3415proc action_contents { action portlist opts } {
3416    global global_options
3417    if {[require_portlist portlist]} {
3418        return 1
3419    }
3420    if {[info exists global_options(ports_contents_size)]} {
3421        set units {}
3422        if {[info exists global_options(ports_contents_units)]} {
3423            set units [complete_size_units $global_options(ports_contents_units)]
3424        }
3425        set outstring {[format "%12s $file" [filesize $file $units]]}
3426    } else {
3427        set outstring {  $file}
3428    }
3429
3430    foreachport $portlist {
3431        if { ![catch {set ilist [registry::installed $portname]} result] } {
3432            # set portname again since the one we were passed may not have had the correct case
3433            set portname [lindex $ilist 0 0]
3434        }
3435        set files [registry::port_registered $portname]
3436        if { $files != 0 } {
3437            if { [llength $files] > 0 } {
3438                ui_notice "Port $portname contains:"
3439                foreach file $files {
3440                    puts [subst $outstring]
3441                }
3442            } else {
3443                ui_notice "Port $portname does not contain any files or is not active."
3444            }
3445        } else {
3446            ui_notice "Port $portname is not installed."
3447        }
3448    }
3449    registry::close_file_map
3450
3451    return 0
3452}
3453
3454# expand abbreviations of size units
3455proc complete_size_units {units} {
3456    if {$units eq "K" || $units eq "Ki"} {
3457        return "KiB"
3458    } elseif {$units eq "k"} {
3459        return "kB"
3460    } elseif {$units eq "Mi"} {
3461        return "MiB"
3462    } elseif {$units eq "M"} {
3463        return "MB"
3464    } elseif {$units eq "Gi"} {
3465        return "GiB"
3466    } elseif {$units eq "G"} {
3467        return "GB"
3468    } else {
3469        return $units
3470    }
3471}
3472
3473# Show space used by the given ports' files
3474proc action_space {action portlist opts} {
3475    global global_options
3476    require_portlist portlist
3477
3478    set units {}
3479    if {[info exists global_options(ports_space_units)]} {
3480        set units [complete_size_units $global_options(ports_space_units)]
3481    }
3482    set spaceall 0.0
3483    foreachport $portlist {
3484        set space 0.0
3485        set files [registry::port_registered $portname]
3486        if { $files != 0 } {
3487            if { [llength $files] > 0 } {
3488                foreach file $files {
3489                    catch {
3490                        set space [expr {$space + [file size $file]}]
3491                    }
3492                }
3493                if {![info exists options(ports_space_total)] || $options(ports_space_total) ne "yes"} {
3494                    set msg "[bytesize $space $units] $portname"
3495                    if { $portversion != {} } {
3496                        append msg " @$portversion"
3497                    }
3498                    puts $msg
3499                }
3500                set spaceall [expr {$space + $spaceall}]
3501            } else {
3502                puts stderr "Port $portname does not contain any file or is not active."
3503            }
3504        } else {
3505            puts stderr "Port $portname is not installed."
3506        }
3507    }
3508    if {[llength $portlist] > 1 || ([info exists options(ports_space_total)] && $options(ports_space_total) eq "yes")} {
3509        puts "[bytesize $spaceall $units] total"
3510    }
3511    return 0
3512}
3513
3514proc action_variants { action portlist opts } {
3515    global global_variations
3516    set status 0
3517    if {[require_portlist portlist]} {
3518        return 1
3519    }
3520    foreachport $portlist {
3521        array unset portinfo
3522        if {$porturl eq ""} {
3523            # look up port
3524            if {[catch {mportlookup $portname} result]} {
3525                global errorInfo
3526                ui_debug "$errorInfo"
3527                break_softcontinue "lookup of portname $portname failed: $result" 1 status
3528            }
3529            if {[llength $result] < 2} {
3530                break_softcontinue "Port $portname not found" 1 status
3531            }
3532
3533            array set portinfo [lindex $result 1]
3534
3535            set porturl $portinfo(porturl)
3536            set portdir $portinfo(portdir)
3537        }
3538
3539        if {!([info exists options(ports_variants_index)] && $options(ports_variants_index) eq "yes")} {
3540            if {![info exists options(subport)]} {
3541                if {[info exists portinfo(name)]} {
3542                    set options(subport) $portinfo(name)
3543                } else {
3544                    set options(subport) $portname
3545                }
3546            }
3547            if {[catch {set mport [mportopen $porturl [array get options] [array get variations]]} result]} {
3548                ui_debug "$::errorInfo"
3549                break_softcontinue "Unable to open port: $result" 1 status
3550            }
3551            array unset portinfo
3552            array set portinfo [mportinfo $mport]
3553            mportclose $mport
3554            if {[info exists portdir]} {
3555                set portinfo(portdir) $portdir
3556            }
3557        } elseif {![info exists portinfo]} {
3558            ui_warn "port variants --index does not work with 'current' pseudo-port"
3559            continue
3560        }
3561
3562        # set portname again since the one we were passed may not have had the correct case
3563        set portname $portinfo(name)
3564
3565        # if this fails the port doesn't have any variants
3566        if {![info exists portinfo(variants)]} {
3567            ui_notice "$portname has no variants"
3568        } else {
3569            array unset vinfo
3570            # Use the new format if it exists.
3571            if {[info exists portinfo(vinfo)]} {
3572                array set vinfo $portinfo(vinfo)
3573            # Otherwise fall back to the old format.
3574            } elseif {[info exists portinfo(variant_desc)]} {
3575                array set vdescriptions $portinfo(variant_desc)
3576            }
3577
3578            # print out all the variants
3579            ui_notice "$portname has the variants:"
3580            foreach v [lsort $portinfo(variants)] {
3581                unset -nocomplain vconflicts vdescription vrequires
3582                set varmodifier "   "
3583                # Retrieve variants' information from the new format.
3584                if {[info exists vinfo]} {
3585                    array unset variant
3586                    array set variant $vinfo($v)
3587
3588                    # Retrieve conflicts, description, is_default, and
3589                    # vrequires.
3590                    if {[info exists variant(conflicts)]} {
3591                        set vconflicts $variant(conflicts)
3592                    }
3593                    if {[info exists variant(description)]} {
3594                        set vdescription $variant(description)
3595                    }
3596
3597                    # XXX Keep these varmodifiers in sync with action_info, or create a wrapper for it
3598                    if {[info exists variations($v)]} {
3599                        set varmodifier "  $variations($v)"
3600                    } elseif {[info exists global_variations($v)]} {
3601                        # selected by variants.conf, prefixed with (+)/(-)
3602                        set varmodifier "($global_variations($v))"
3603                    } elseif {[info exists variant(is_default)]} {
3604                        set varmodifier "\[$variant(is_default)\]"
3605                    }
3606                    if {[info exists variant(requires)]} {
3607                        set vrequires $variant(requires)
3608                    }
3609                # Retrieve variants' information from the old format,
3610                # which only consists of the description.
3611                } elseif {[info exists vdescriptions($v)]} {
3612                    set vdescription $vdescriptions($v)
3613                }
3614
3615                if {[info exists vdescription]} {
3616                    puts [wraplabel "$varmodifier$v" [string trim $vdescription] 0 [string repeat " " [expr 5 + [string length $v]]]]
3617                } else {
3618                    puts "$varmodifier$v"
3619                }
3620                if {[info exists vconflicts]} {
3621                    puts "     * conflicts with [string trim $vconflicts]"
3622                }
3623                if {[info exists vrequires]} {
3624                    puts "     * requires [string trim $vrequires]"
3625                }
3626            }
3627        }
3628    }
3629
3630    return $status
3631}
3632
3633
3634proc action_search { action portlist opts } {
3635    global private_options global_options
3636    set status 0
3637    if {![llength $portlist] && [info exists private_options(ports_no_args)] && $private_options(ports_no_args) eq "yes"} {
3638        ui_error "You must specify a search pattern"
3639        return 1
3640    }
3641
3642    # Copy global options as we are going to modify the array
3643    array set options [array get global_options]
3644
3645    if {[info exists options(ports_search_depends)] && $options(ports_search_depends) eq "yes"} {
3646        array unset options ports_search_depends
3647        set options(ports_search_depends_fetch) yes
3648        set options(ports_search_depends_extract) yes
3649        set options(ports_search_depends_build) yes
3650        set options(ports_search_depends_lib) yes
3651        set options(ports_search_depends_run) yes
3652    }
3653
3654    # Array to hold given filters
3655    array set filters {}
3656    # Default matchstyle
3657    set filter_matchstyle "none"
3658    set filter_case no
3659    foreach { option } [array names options ports_search_*] {
3660        set opt [string range $option 13 end]
3661
3662        if { $options($option) ne "yes" } {
3663            continue
3664        }
3665        switch -- $opt {
3666            exact -
3667            glob {
3668                set filter_matchstyle $opt
3669                continue
3670            }
3671            regex {
3672                set filter_matchstyle regexp
3673                continue
3674            }
3675            case-sensitive {
3676                set filter_case yes
3677                continue
3678            }
3679            line {
3680                continue
3681            }
3682        }
3683
3684        set filters($opt) "yes"
3685    }
3686    # Set default search filter if none was given
3687    if { [array size filters] == 0 } {
3688        set filters(name) "yes"
3689        set filters(description) "yes"
3690    }
3691
3692    set separator ""
3693    foreach portname $portlist {
3694        puts -nonewline $separator
3695
3696        set searchstring $portname
3697        set matchstyle $filter_matchstyle
3698        if {$matchstyle eq "none"} {
3699            # Guess if the given string was a glob expression, if not do a substring search
3700            if {[string first "*" $portname] == -1 && [string first "?" $portname] == -1} {
3701                set searchstring "*$portname*"
3702            }
3703            set matchstyle glob
3704        }
3705
3706        set res {}
3707        set portfound 0
3708        foreach { opt } [array get filters] {
3709            # Map from friendly name
3710            set opt [map_friendly_field_names $opt]
3711
3712            if {[catch {set matches [mportsearch $searchstring $filter_case $matchstyle $opt]} result]} {
3713                global errorInfo
3714                ui_debug "$errorInfo"
3715                break_softcontinue "search for name $portname failed: $result" 1 status
3716            }
3717
3718            set tmp {}
3719            foreach {name info} $matches {
3720                add_to_portlist tmp [concat [list name $name] $info]
3721            }
3722            set res [opUnion $res $tmp]
3723        }
3724        set res [portlist_sort $res]
3725
3726        set joiner ""
3727        foreach info $res {
3728            array unset portinfo
3729            array set portinfo $info
3730
3731            # XXX is this the right place to verify an entry?
3732            if {![info exists portinfo(name)]} {
3733                puts stderr "Invalid port entry, missing portname"
3734                continue
3735            }
3736            if {![info exists portinfo(description)]} {
3737                puts stderr "Invalid port entry for $portinfo(name), missing description"
3738                continue
3739            }
3740            if {![info exists portinfo(version)]} {
3741                puts stderr "Invalid port entry for $portinfo(name), missing version"
3742                continue
3743            }
3744
3745            if {[macports::ui_isset ports_quiet]} {
3746                puts $portinfo(name)
3747            } else {
3748                if {[info exists options(ports_search_line)]
3749                        && $options(ports_search_line) eq "yes"} {
3750                    # check for ports without category, e.g. replaced_by stubs
3751                    if {[info exists portinfo(categories)]} {
3752                        puts "$portinfo(name)\t$portinfo(version)\t$portinfo(categories)\t$portinfo(description)"
3753                    } else {
3754                        # keep two consecutive tabs in order to provide consistent columns' content
3755                        puts "$portinfo(name)\t$portinfo(version)\t\t$portinfo(description)"
3756                    }
3757                } else {
3758                    puts -nonewline $joiner
3759
3760                    puts -nonewline "$portinfo(name) @$portinfo(version)"
3761                    if {[info exists portinfo(revision)] && $portinfo(revision) > 0} {
3762                        puts -nonewline "_$portinfo(revision)"
3763                    }
3764                    if {[info exists portinfo(categories)]} {
3765                        puts -nonewline " ([join $portinfo(categories) ", "])"
3766                    }
3767                    puts ""
3768                    puts [wrap [join $portinfo(description)] 0 [string repeat " " 4]]
3769                }
3770            }
3771
3772            set joiner "\n"
3773            set portfound 1
3774        }
3775        if { !$portfound } {
3776            ui_notice "No match for $portname found"
3777        } elseif {[llength $res] > 1} {
3778            if {(![info exists global_options(ports_search_line)]
3779                    || $global_options(ports_search_line) ne "yes")} {
3780                ui_notice "\nFound [llength $res] ports."
3781            }
3782        }
3783
3784        set separator "--\n"
3785    }
3786
3787    array unset options
3788    array unset filters
3789
3790    return $status
3791}
3792
3793
3794proc action_list { action portlist opts } {
3795    global private_options
3796    set status 0
3797   
3798    # Default to list all ports if no portnames are supplied
3799    if { ![llength $portlist] && [info exists private_options(ports_no_args)] && $private_options(ports_no_args) eq "yes"} {
3800        add_to_portlist portlist [list name "-all-"]
3801    }
3802   
3803    foreachport $portlist {
3804        if {$portname eq "-all-"} {
3805           if {[catch {set res [mportlistall]} result]} {
3806                global errorInfo
3807                ui_debug "$errorInfo"
3808                break_softcontinue "listing all ports failed: $result" 1 status
3809            }
3810        } else {
3811            if {$portversion ne "" && ![info exists warned_for_version]} {
3812                ui_warn "The 'list' action only shows the currently available version of each port. To see installed versions, use the 'installed' action."
3813                set warned_for_version 1
3814            }
3815            set search_string [regex_pat_sanitize $portname]
3816            if {[catch {set res [mportsearch ^$search_string\$ no]} result]} {
3817                global errorInfo
3818                ui_debug "$errorInfo"
3819                break_softcontinue "search for portname $search_string failed: $result" 1 status
3820            }
3821        }
3822
3823        foreach {name array} $res {
3824            array unset portinfo
3825            array set portinfo $array
3826            set outdir ""
3827            if {[info exists portinfo(portdir)]} {
3828                set outdir $portinfo(portdir)
3829            }
3830            puts [format "%-30s @%-14s %s" $portinfo(name) $portinfo(version) $outdir]
3831        }
3832    }
3833   
3834    return $status
3835}
3836
3837
3838proc action_echo { action portlist opts } {
3839    global global_options
3840
3841    # Simply echo back the port specs given to this command
3842    foreachport $portlist {
3843        if {![macports::ui_isset ports_quiet]} {
3844            set opts {}
3845            foreach { key value } [array get options] {
3846                if {![info exists global_options($key)]} {
3847                    lappend opts "$key=$value"
3848                }
3849            }
3850
3851            set composite_version [composite_version $portversion [array get variations] 1]
3852            if { $composite_version ne "" } {
3853                set ver_field "@$composite_version"
3854            } else {
3855                set ver_field ""
3856            }
3857            puts [format "%-30s %s %s" $portname $ver_field  [join $opts " "]]
3858        } else {
3859            puts "$portname"
3860        }
3861    }
3862
3863    return 0
3864}
3865
3866
3867proc action_portcmds { action portlist opts } {
3868    # Operations on the port's directory and Portfile
3869    global env boot_env current_portdir
3870
3871    array set local_options $opts
3872   
3873    set status 0
3874    if {[require_portlist portlist]} {
3875        return 1
3876    }
3877    foreachport $portlist {
3878        array unset portinfo
3879        # If we have a url, use that, since it's most specific, otherwise try to map the portname to a url
3880        if {$porturl eq ""} {
3881       
3882            # Verify the portname, getting portinfo to map to a porturl
3883            if {[catch {set res [mportlookup $portname]} result]} {
3884                global errorInfo
3885                ui_debug "$errorInfo"
3886                break_softcontinue "lookup of portname $portname failed: $result" 1 status
3887            }
3888            if {[llength $res] < 2} {
3889                break_softcontinue "Port $portname not found" 1 status
3890            }
3891            array set portinfo [lindex $res 1]
3892            set porturl $portinfo(porturl)
3893            set portname $portinfo(name)
3894        }
3895       
3896       
3897        # Calculate portdir, porturl, and portfile from initial porturl
3898        set portdir [file normalize [macports::getportdir $porturl]]
3899        set porturl "file://${portdir}";    # Rebuild url so it's fully qualified
3900        set portfile "${portdir}/Portfile"
3901       
3902        # Now execute the specific action
3903        if {[file readable $portfile]} {
3904            switch -- $action {
3905                cat {
3906                    # Copy the portfile to standard output
3907                    set f [open $portfile RDONLY]
3908                    while { ![eof $f] } {
3909                        puts -nonewline [read $f 4096]
3910                    }
3911                    close $f
3912                }
3913               
3914                edit {
3915                    # Edit the port's portfile with the user's editor
3916                   
3917                    # Restore our entire environment from start time.
3918                    # We need it to evaluate the editor, and the editor
3919                    # may want stuff from it as well, like TERM.
3920                    array unset env_save; array set env_save [array get env]
3921                    array unset env *
3922                    if {${macports::macosx_version} eq "10.5"} {
3923                        unsetenv *
3924                    }
3925                    array set env [array get boot_env]
3926                   
3927                    # Find an editor to edit the portfile
3928                    set editor ""
3929                    set editor_var "ports_${action}_editor"
3930                    if {[info exists local_options($editor_var)]} {
3931                        set editor [join $local_options($editor_var)]
3932                    } else {
3933                        foreach ed { MP_EDITOR VISUAL EDITOR } {
3934                            if {[info exists env($ed)]} {
3935                                set editor $env($ed)
3936                                break
3937                            }
3938                        }
3939                    }
3940                   
3941                    # Use a reasonable canned default if no editor specified or set in env
3942                    if { $editor eq "" } { set editor "/usr/bin/vi" }
3943                   
3944                    # Invoke the editor
3945                    if {[catch {exec -ignorestderr >@stdout <@stdin {*}$editor $portfile} result]} {
3946                        global errorInfo
3947                        ui_debug "$errorInfo"
3948                        break_softcontinue "unable to invoke editor $editor: $result" 1 status
3949                    }
3950                   
3951                    # Restore internal MacPorts environment
3952                    array unset env *
3953                    if {${macports::macosx_version} eq "10.5"} {
3954                        unsetenv *
3955                    }
3956                    array set env [array get env_save]
3957                }
3958
3959                dir {
3960                    # output the path to the port's directory
3961                    puts $portdir
3962                }
3963
3964                work {
3965                    # output the path to the port's work directory
3966                    set workpath [macports::getportworkpath_from_portdir $portdir $portname]
3967                    if {[file exists $workpath]} {
3968                        puts $workpath
3969                    }
3970                }
3971
3972                cd {
3973                    # Change to the port's directory, making it the default
3974                    # port for any future commands
3975                    set current_portdir $portdir
3976                }
3977
3978                url {
3979                    # output the url of the port's directory, suitable to feed back in later as a port descriptor
3980                    puts $porturl
3981                }
3982
3983                file {
3984                    # output the path to the port's portfile
3985                    puts $portfile
3986                }
3987
3988                logfile {
3989                    set logfile [file join [macports::getportlogpath $portdir $portname] "main.log"]
3990                    if {[file isfile $logfile]} {
3991                        puts $logfile
3992                    } else {
3993                        ui_error "Log file not found for port in $portdir"
3994                    }
3995                }
3996
3997                gohome {
3998                    set homepage ""
3999
4000                    # Get the homepage as read from PortIndex
4001                    if {[info exists portinfo(homepage)]} {
4002                        set homepage $portinfo(homepage)
4003                    }
4004
4005                    # If not available, get the homepage for the port by opening the Portfile
4006                    if {$homepage eq "" && ![catch {set ctx [mportopen $porturl]} result]} {
4007                        array set portinfo [mportinfo $ctx]
4008                        if {[info exists portinfo(homepage)]} {
4009                            set homepage $portinfo(homepage)
4010                        }
4011                        mportclose $ctx
4012                    }
4013
4014                    # Try to open a browser to the homepage for the given port
4015                    if { $homepage ne "" } {
4016                        if {[catch {system "${macports::autoconf::open_path} '$homepage'"} result]} {
4017                            global errorInfo
4018                            ui_debug "$errorInfo"
4019                            break_softcontinue "unable to invoke browser using ${macports::autoconf::open_path}: $result" 1 status
4020                        }
4021                    } else {
4022                        ui_error [format "No homepage for %s" $portname]
4023                    }
4024                }
4025            }
4026        } else {
4027            break_softcontinue "Could not read $portfile" 1 status
4028        }
4029    }
4030   
4031    return $status
4032}
4033
4034
4035proc action_sync { action portlist opts } {
4036    global global_options
4037
4038    set status 0
4039    if {[catch {mportsync [array get global_options]} result]} {
4040        global errorInfo
4041        ui_debug "$errorInfo"
4042        ui_msg "port sync failed: $result"
4043        set status 1
4044    }
4045   
4046    return $status
4047}
4048
4049
4050proc action_target { action portlist opts } {
4051    global global_variations
4052    set status 0
4053    if {[require_portlist portlist]} {
4054        return 1
4055    }
4056    if {($action eq "install" || $action eq "archive") && [prefix_unwritable] && ![macports::global_option_isset ports_dryrun]} {
4057        return 1
4058    }
4059    foreachport $portlist {
4060        array unset portinfo
4061        # If we have a url, use that, since it's most specific
4062        # otherwise try to map the portname to a url
4063        if {$porturl eq ""} {
4064            # Verify the portname, getting portinfo to map to a porturl
4065            if {[catch {set res [mportlookup $portname]} result]} {
4066                global errorInfo
4067                ui_debug "$errorInfo"
4068                break_softcontinue "lookup of portname $portname failed: $result" 1 status
4069            }
4070            if {[llength $res] < 2} {
4071                # don't error for ports that are installed but not in the tree
4072                if {[registry::entry_exists_for_name $portname]} {
4073                    ui_warn "Skipping $portname (not in the ports tree)"
4074                    continue
4075                } else {
4076                    break_softcontinue "Port $portname not found" 1 status
4077                }
4078            }
4079            array set portinfo [lindex $res 1]
4080            set porturl $portinfo(porturl)
4081        }
4082
4083        # use existing variants iff none were explicitly requested
4084        if {[array get requested_variations] eq "" && [array get variations] ne ""} {
4085            array unset requested_variations
4086            array set requested_variations [array get variations]
4087        }
4088
4089        # Add any global_variations to the variations
4090        # specified for the port
4091        foreach { variation value } [array get global_variations] {
4092            if { ![info exists requested_variations($variation)] } {
4093                set requested_variations($variation) $value
4094            }
4095        }
4096
4097        # If version was specified, save it as a version glob for use
4098        # in port actions (e.g. clean).
4099        if {[string length $portversion]} {
4100            set options(ports_version_glob) $portversion
4101        }
4102        # if installing, mark the port as explicitly requested
4103        if {$action eq "install"} {
4104            if {![info exists options(ports_install_unrequested)]} {
4105                set options(ports_requested) 1
4106            }
4107            # we actually activate as well
4108            set target activate
4109        } elseif {$action eq "archive"} {
4110            set target install
4111        } else {
4112            set target $action
4113        }
4114        if {![info exists options(subport)]} {
4115            if {[info exists portinfo(name)]} {
4116                set options(subport) $portinfo(name)
4117            } else {
4118                set options(subport) $portname
4119            }
4120        }
4121        if {[catch {set workername [mportopen $porturl [array get options] [array get requested_variations]]} result]} {
4122            global errorInfo
4123            ui_debug "$errorInfo"
4124            break_softcontinue "Unable to open port: $result" 1 status
4125        }
4126        if {[catch {set result [mportexec $workername $target]} result]} {
4127            global errorInfo
4128            mportclose $workername
4129            ui_debug "$errorInfo"
4130            break_softcontinue "Unable to execute port: $result" 1 status
4131        }
4132
4133        mportclose $workername
4134       
4135        # Process any error that wasn't thrown and handled already
4136        if {$result} {
4137            print_tickets_url
4138            break_softcontinue "Processing of port $portname failed" 1 status
4139        }
4140    }
4141   
4142    if {$status == 0 && $action eq "install" && ![macports::global_option_isset ports_dryrun]} {
4143        array set options $opts
4144        if {![info exists options(ports_nodeps)] && ![info exists options(ports_install_no-rev-upgrade)] && ${macports::revupgrade_autorun}} {
4145            set status [action_revupgrade $action $portlist $opts]
4146        }
4147    }
4148
4149    return $status
4150}
4151
4152
4153proc action_exit { action portlist opts } {
4154    # Return a semaphore telling the main loop to quit
4155    return -999
4156}
4157
4158
4159##########################################
4160# Command Parsing
4161##########################################
4162proc moreargs {} {
4163    global cmd_argn cmd_argc
4164    return [expr {$cmd_argn < $cmd_argc}]
4165}
4166
4167
4168proc lookahead {} {
4169    global cmd_argn cmd_argc cmd_argv
4170    if {$cmd_argn < $cmd_argc} {
4171        return [lindex $cmd_argv $cmd_argn]
4172    } else {
4173        return _EOF_
4174    }
4175}
4176
4177
4178proc advance {} {
4179    global cmd_argn
4180    incr cmd_argn
4181}
4182
4183
4184proc match s {
4185    if {[lookahead] == $s} {
4186        advance
4187        return 1
4188    }
4189    return 0
4190}
4191
4192# action_array specifies which action to run on the given command
4193# and if the action wants an expanded portlist.
4194# The value is a list of the form {action expand},
4195# where action is a string and expand a value:
4196#   0 none        Does not expect any text argument
4197#   1 strings     Expects some strings as text argument
4198#   2 ports       Wants an expanded list of ports as text argument
4199global action_array
4200
4201# Define global constants
4202const ACTION_ARGS_NONE 0
4203const ACTION_ARGS_STRINGS 1
4204const ACTION_ARGS_PORTS 2
4205
4206array set action_array [list \
4207    usage       [list action_usage          [ACTION_ARGS_STRINGS]] \
4208    help        [list action_help           [ACTION_ARGS_STRINGS]] \
4209    \
4210    echo        [list action_echo           [ACTION_ARGS_PORTS]] \
4211    \
4212    info        [list action_info           [ACTION_ARGS_PORTS]] \
4213    location    [list action_location       [ACTION_ARGS_PORTS]] \
4214    notes       [list action_notes          [ACTION_ARGS_PORTS]] \
4215    provides    [list action_provides       [ACTION_ARGS_STRINGS]] \
4216    log         [list action_log            [ACTION_ARGS_PORTS]] \
4217    \
4218    activate    [list action_activate       [ACTION_ARGS_PORTS]] \
4219    deactivate  [list action_deactivate     [ACTION_ARGS_PORTS]] \
4220    \
4221    select      [list action_select         [ACTION_ARGS_STRINGS]] \
4222    \
4223    sync        [list action_sync           [ACTION_ARGS_NONE]] \
4224    selfupdate  [list action_selfupdate     [ACTION_ARGS_NONE]] \
4225    \
4226    setrequested   [list action_setrequested  [ACTION_ARGS_PORTS]] \
4227    unsetrequested [list action_setrequested  [ACTION_ARGS_PORTS]] \
4228    setunrequested [list action_setrequested  [ACTION_ARGS_PORTS]] \
4229    \
4230    upgrade     [list action_upgrade        [ACTION_ARGS_PORTS]] \
4231    rev-upgrade [list action_revupgrade     [ACTION_ARGS_NONE]] \
4232    reclaim     [list action_reclaim        [ACTION_ARGS_NONE]] \
4233    diagnose    [list action_diagnose       [ACTION_ARGS_NONE]] \
4234    \
4235    version     [list action_version        [ACTION_ARGS_NONE]] \
4236    platform    [list action_platform       [ACTION_ARGS_NONE]] \
4237    \
4238    uninstall   [list action_uninstall      [ACTION_ARGS_PORTS]] \
4239    \
4240    installed   [list action_installed      [ACTION_ARGS_PORTS]] \
4241    outdated    [list action_outdated       [ACTION_ARGS_PORTS]] \
4242    contents    [list action_contents       [ACTION_ARGS_PORTS]] \
4243    space       [list action_space          [ACTION_ARGS_PORTS]] \
4244    dependents  [list action_dependents     [ACTION_ARGS_PORTS]] \
4245    rdependents [list action_dependents     [ACTION_ARGS_PORTS]] \
4246    deps        [list action_deps           [ACTION_ARGS_PORTS]] \
4247    rdeps       [list action_deps           [ACTION_ARGS_PORTS]] \
4248    variants    [list action_variants       [ACTION_ARGS_PORTS]] \
4249    \
4250    search      [list action_search         [ACTION_ARGS_STRINGS]] \
4251    list        [list action_list           [ACTION_ARGS_PORTS]] \
4252    \
4253    edit        [list action_portcmds       [ACTION_ARGS_PORTS]] \
4254    cat         [list action_portcmds       [ACTION_ARGS_PORTS]] \
4255    dir         [list action_portcmds       [ACTION_ARGS_PORTS]] \
4256    work        [list action_portcmds       [ACTION_ARGS_PORTS]] \
4257    cd          [list action_portcmds       [ACTION_ARGS_PORTS]] \
4258    url         [list action_portcmds       [ACTION_ARGS_PORTS]] \
4259    file        [list action_portcmds       [ACTION_ARGS_PORTS]] \
4260    logfile     [list action_portcmds       [ACTION_ARGS_PORTS]] \
4261    gohome      [list action_portcmds       [ACTION_ARGS_PORTS]] \
4262    \
4263    fetch       [list action_target         [ACTION_ARGS_PORTS]] \
4264    checksum    [list action_target         [ACTION_ARGS_PORTS]] \
4265    extract     [list action_target         [ACTION_ARGS_PORTS]] \
4266    patch       [list action_target         [ACTION_ARGS_PORTS]] \
4267    configure   [list action_target         [ACTION_ARGS_PORTS]] \
4268    build       [list action_target         [ACTION_ARGS_PORTS]] \
4269    destroot    [list action_target         [ACTION_ARGS_PORTS]] \
4270    install     [list action_target         [ACTION_ARGS_PORTS]] \
4271    clean       [list action_target         [ACTION_ARGS_PORTS]] \
4272    test        [list action_target         [ACTION_ARGS_PORTS]] \
4273    lint        [list action_target         [ACTION_ARGS_PORTS]] \
4274    livecheck   [list action_target         [ACTION_ARGS_PORTS]] \
4275    distcheck   [list action_target         [ACTION_ARGS_PORTS]] \
4276    mirror      [list action_target         [ACTION_ARGS_PORTS]] \
4277    load        [list action_target         [ACTION_ARGS_PORTS]] \
4278    unload      [list action_target         [ACTION_ARGS_PORTS]] \
4279    reload      [list action_target         [ACTION_ARGS_PORTS]] \
4280    distfiles   [list action_target         [ACTION_ARGS_PORTS]] \
4281    \
4282    archivefetch [list action_target         [ACTION_ARGS_PORTS]] \
4283    archive     [list action_target         [ACTION_ARGS_PORTS]] \
4284    unarchive   [list action_target         [ACTION_ARGS_PORTS]] \
4285    dmg         [list action_target         [ACTION_ARGS_PORTS]] \
4286    mdmg        [list action_target         [ACTION_ARGS_PORTS]] \
4287    mpkg        [list action_target         [ACTION_ARGS_PORTS]] \
4288    pkg         [list action_target         [ACTION_ARGS_PORTS]] \
4289    \
4290    quit        [list action_exit           [ACTION_ARGS_NONE]] \
4291    exit        [list action_exit           [ACTION_ARGS_NONE]] \
4292]
4293
4294# Expand "action".
4295# Returns an action proc, or a list of matching action procs, or the action passed in
4296proc find_action { action } {
4297    global action_array
4298   
4299    if { ! [info exists action_array($action)] } {
4300        set guess [guess_action $action]
4301        if { [info exists action_array($guess)] } {
4302            return $guess
4303        }
4304        return $guess
4305    }
4306   
4307    return $action
4308}
4309
4310# Expand action
4311# If there's more than one match, return the next possibility
4312proc find_action_proc { action } {
4313    global action_array
4314   
4315    set action_proc ""
4316    if { [info exists action_array($action)] } {
4317        set action_proc [lindex $action_array($action) 0]
4318    } else {
4319        set action [complete_action $action]
4320        if { [info exists action_array($action)] } {
4321            set action_proc [lindex $action_array($action) 0]
4322        }
4323    }
4324   
4325    return $action_proc
4326}
4327
4328proc get_action_proc { action } {
4329    global action_array
4330   
4331    set action_proc ""
4332    if { [info exists action_array($action)] } {
4333        set action_proc [lindex $action_array($action) 0]
4334    }
4335   
4336    return $action_proc
4337}
4338
4339# Returns whether an action expects text arguments at all,
4340# expects text arguments or wants an expanded list of ports
4341# Return values are constants:
4342#   [ACTION_ARGS_NONE]     Does not expect any text argument
4343#   [ACTION_ARGS_STRINGS]  Expects some strings as text argument
4344#   [ACTION_ARGS_PORTS]    Wants an expanded list of ports as text argument
4345proc action_needs_portlist { action } {
4346    global action_array
4347
4348    set ret 0
4349    if {[info exists action_array($action)]} {
4350        set ret [lindex $action_array($action) 1]
4351    }
4352
4353    return $ret
4354}
4355
4356# cmd_opts_array specifies which arguments the commands accept
4357# Commands not listed here do not accept any arguments
4358# Syntax if {option argn}
4359# Where option is the name of the option and argn specifies how many arguments
4360# this argument takes
4361global cmd_opts_array
4362array set cmd_opts_array {
4363    edit        {{editor 1}}
4364    info        {category categories conflicts depends_fetch depends_extract
4365                 depends_build depends_lib depends_run
4366                 depends description epoch fullname heading homepage index license
4367                 line long_description
4368                 maintainer maintainers name patchfiles platform platforms portdir
4369                 pretty replaced_by revision subports variant variants version}
4370    contents    {size {units 1}}
4371    deps        {index no-build}
4372    rdeps       {index no-build full}
4373    rdependents {full}
4374    search      {case-sensitive category categories depends_fetch
4375                 depends_extract depends_build depends_lib depends_run
4376                 depends description epoch exact glob homepage line
4377                 long_description maintainer maintainers name platform
4378                 platforms portdir regex revision variant variants version}
4379    selfupdate  {nosync}
4380    space       {{units 1} total}
4381    activate    {no-exec}
4382    deactivate  {no-exec}
4383    install     {no-rev-upgrade unrequested}
4384    uninstall   {follow-dependents follow-dependencies no-exec}
4385    variants    {index}
4386    clean       {all archive dist work logs}
4387    mirror      {new}
4388    lint        {nitpick}
4389    select      {list set show summary}
4390    log         {{phase 1} {level 1}}
4391    upgrade     {force enforce-variants no-replace no-rev-upgrade}
4392    rev-upgrade {id-loadcmd-check}
4393    diagnose    {quiet}
4394}
4395
4396##
4397# Checks whether the given option is valid
4398#
4399# @param action for which action
4400# @param option the prefix of the option to check
4401# @return list of pairs {name argc} for all matching options
4402proc cmd_option_matches {action option} {
4403    global cmd_opts_array
4404
4405    # This could be so easy with lsearch -index,
4406    # but that's only available as of Tcl 8.5
4407
4408    if {![info exists cmd_opts_array($action)]} {
4409        return {}
4410    }
4411
4412    set result {}
4413
4414    foreach item $cmd_opts_array($action) {
4415        if {[llength $item] == 1} {
4416            set name $item
4417            set argc 0
4418        } else {
4419            set name [lindex $item 0]
4420            set argc [lindex $item 1]
4421        }
4422
4423        if {$name == $option} {
4424            set result [list [list $name $argc]]
4425            break
4426        } elseif {[string first $option $name] == 0} {
4427            lappend result [list $name $argc]
4428        }
4429    }
4430
4431    return $result
4432}
4433
4434# Parse global options
4435#
4436# Note that this is called several times:
4437#   (1) Initially, to parse options that will be constant across all commands
4438#       (options that come prior to any command, frozen into global_options_base)
4439#   (2) Following each command (to parse options that will be unique to that command
4440#       (the global_options array is reset to global_options_base prior to each command)
4441#
4442proc parse_options { action ui_options_name global_options_name } {
4443    upvar $ui_options_name ui_options
4444    upvar $global_options_name global_options
4445    global cmdname cmd_opts_array
4446   
4447    while {[moreargs]} {
4448        set arg [lookahead]
4449       
4450        if {[string index $arg 0] ne "-"} {
4451            break
4452        } elseif {[string index $arg 1] eq "-"} {
4453            # Process long arguments
4454            switch -- $arg {
4455                -- { # This is the options terminator; do no further option processing
4456                    advance; break
4457                }
4458                default {
4459                    set key [string range $arg 2 end]
4460                    set kopts [cmd_option_matches $action $key]
4461                    if {[llength $kopts] == 0} {
4462                        return -code error "${action} does not accept --${key}"
4463                    } elseif {[llength $kopts] > 1} {
4464                        set errlst {}
4465                        foreach e $kopts {
4466                            lappend errlst "--[lindex $e 0]"
4467                        }
4468                        return -code error "\"port ${action} --${key}\" is ambiguous: \n  port ${action} [join $errlst "\n  port ${action} "]"
4469                    }
4470                    set key   [lindex $kopts 0 0]
4471                    set kargc [lindex $kopts 0 1]
4472                    if {$kargc == 0} {
4473                        set global_options(ports_${action}_${key}) yes
4474                    } else {
4475                        set args {}
4476                        while {[moreargs] && $kargc > 0} {
4477                            advance
4478                            lappend args [lookahead]
4479                            set kargc [expr {$kargc - 1}]
4480                        }
4481                        if {$kargc > 0} {
4482                            return -code error "--${key} expects [expr {$kargc + [llength $args]}] parameters!"
4483                        }
4484                        set global_options(ports_${action}_${key}) $args
4485                    }
4486                }
4487            }
4488        } else {
4489            # Process short arg(s)
4490            set opts [string range $arg 1 end]
4491            foreach c [split $opts {}] {
4492                switch -- $c {
4493                    v {
4494                        set ui_options(ports_verbose) yes
4495                    }
4496                    d {
4497                        set ui_options(ports_debug) yes
4498                        # debug implies verbose
4499                        set ui_options(ports_verbose) yes
4500                    }
4501                    q {
4502                        set ui_options(ports_quiet) yes
4503                        # quiet implies noninteractive
4504                        set ui_options(ports_noninteractive) yes
4505                    }
4506                    p {
4507                        # Ignore errors while processing within a command
4508                        set ui_options(ports_processall) yes
4509                    }
4510                    N { 
4511                        # Interactive mode is available or not
4512                        set ui_options(ports_noninteractive) yes
4513                    }
4514                    f {
4515                        set global_options(ports_force) yes
4516                    }
4517                    o {
4518                        set global_options(ports_ignore_different) yes
4519                    }
4520                    n {
4521                        set global_options(ports_nodeps) yes
4522                    }
4523                    u {
4524                        set global_options(port_uninstall_old) yes
4525                    }
4526                    R {
4527                        set global_options(ports_do_dependents) yes
4528                    }
4529                    s {
4530                        set global_options(ports_source_only) yes
4531                    }
4532                    b {
4533                        set global_options(ports_binary_only) yes
4534                    }
4535                    c {
4536                        set global_options(ports_autoclean) yes
4537                    }
4538                    k {
4539                        set global_options(ports_autoclean) no
4540                    }
4541                    t {
4542                        set global_options(ports_trace) yes
4543                    }
4544                    y {
4545                        set global_options(ports_dryrun) yes
4546                    }
4547                    F {
4548                        # Name a command file to process
4549                        advance
4550                        if {[moreargs]} {
4551                            lappend ui_options(ports_commandfiles) [lookahead]
4552                        }
4553                    }
4554                    D {
4555                        advance
4556                        if {[moreargs]} {
4557                            cd [lookahead]
4558                        }
4559                        break
4560                    }
4561                    default {
4562                        print_usage; exit 1
4563                    }
4564                }
4565            }
4566        }
4567
4568        advance
4569    }
4570}
4571
4572# acquire exclusive registry lock for actions that need it
4573# returns 1 if locked, 0 otherwise
4574proc lock_reg_if_needed {action} {
4575    switch -- $action {
4576        activate -
4577        deactivate -
4578        setrequested -
4579        unsetrequested -
4580        setunrequested -
4581        upgrade -
4582        uninstall -
4583        install {
4584            registry::exclusive_lock
4585            return 1
4586        }
4587    }
4588    return 0
4589}
4590
4591proc process_cmd { argv } {
4592    global cmd_argc cmd_argv cmd_argn \
4593           global_options global_options_base private_options ui_options \
4594           current_portdir
4595    set cmd_argv $argv
4596    set cmd_argc [llength $argv]
4597    set cmd_argn 0
4598
4599    set action_status 0
4600
4601    # Process an action if there is one
4602    while {($action_status == 0 || [macports::ui_isset ports_processall]) && [moreargs]} {
4603        set action [lookahead]
4604        advance
4605       
4606        # Handle command separator
4607        if { $action == ";" } {
4608            continue
4609        }
4610       
4611        # Handle a comment
4612        if { [string index $action 0] == "#" } {
4613            while { [moreargs] } { advance }
4614            break
4615        }
4616
4617        set locked [lock_reg_if_needed $action]
4618        # Always start out processing an action in current_portdir
4619        cd $current_portdir
4620       
4621        # Reset global_options from base before each action, as we munge it just below...
4622        array unset global_options
4623        array set global_options $global_options_base
4624       
4625        # Find an action to execute
4626        set actions [find_action $action]
4627        if {[llength $actions] == 1} {
4628            set action [lindex $actions 0]
4629            set action_proc [get_action_proc $action]
4630        } else {
4631            if {[llength $actions] > 1} {
4632                ui_error "\"port ${action}\" is ambiguous: \n  port [join $actions "\n  port "]"
4633            } else {
4634                ui_error "Unrecognized action \"port $action\""
4635            }
4636            set action_status 1
4637            break
4638        }
4639
4640        # Parse options that will be unique to this action
4641        # (to avoid abiguity with -variants and a default port, either -- must be
4642        # used to terminate option processing, or the pseudo-port current must be specified).
4643        if {[catch {parse_options $action ui_options global_options} result]} {
4644            global errorInfo
4645            ui_debug "$errorInfo"
4646            ui_error $result
4647            set action_status 1
4648            break
4649        }
4650
4651        # What kind of arguments does the command expect?
4652        set expand [action_needs_portlist $action]
4653
4654        # (Re-)initialize private_options(ports_no_args) to no, because it might still be yes
4655        # from the last command in batch mode. If we don't do this, port will fail to
4656        # distinguish arguments that expand to empty lists from no arguments at all:
4657        # > installed
4658        # > list outdated
4659        # will then behave like
4660        # > list
4661        # if outdated expands to the empty list. See #44091, which was filed about this.
4662        set private_options(ports_no_args) "no"
4663
4664        # Parse action arguments, setting a special flag if there were none
4665        # We otherwise can't tell the difference between arguments that evaluate
4666        # to the empty set, and the empty set itself.
4667        set portlist {}
4668        switch -- [lookahead] {
4669            ;       -
4670            _EOF_ {
4671                set private_options(ports_no_args) "yes"
4672            }
4673            default {
4674                if {[ACTION_ARGS_NONE] == $expand} {
4675                    ui_error "$action does not accept string arguments"
4676                    set action_status 1
4677                    break
4678                } elseif {[ACTION_ARGS_STRINGS] == $expand} {
4679                    while { [moreargs] && ![match ";"] } {
4680                        lappend portlist [lookahead]
4681                        advance
4682                    }
4683                } elseif {[ACTION_ARGS_PORTS] == $expand} {
4684                    # Parse port specifications into portlist
4685                    if {![portExpr portlist]} {
4686                        ui_error "Improper expression syntax while processing parameters"
4687                        set action_status 1
4688                        break
4689                    }
4690                }
4691            }
4692        }
4693       
4694        # execute the action
4695        set action_status [$action_proc $action $portlist [array get global_options]]
4696
4697        # unlock if needed
4698        if {$locked} {
4699            registry::exclusive_unlock
4700        }
4701
4702        # Print notifications of just-activated ports.
4703        portclient::notifications::display
4704
4705        # semaphore to exit
4706        if {$action_status == -999} break
4707    }
4708   
4709    return $action_status
4710}
4711
4712
4713proc complete_portname { text state } { 
4714    global complete_choices complete_position
4715   
4716    if {$state == 0} {
4717        set complete_position 0
4718        set complete_choices {}
4719
4720        # Build a list of ports with text as their prefix
4721        if {[catch {set res [mportsearch "${text}*" false glob]} result]} {
4722            global errorInfo
4723            ui_debug "$errorInfo"
4724            fatal "search for portname $pattern failed: $result"
4725        }
4726        foreach {name info} $res {
4727            lappend complete_choices $name
4728        }
4729    }
4730   
4731    set word [lindex $complete_choices $complete_position]
4732    incr complete_position
4733   
4734    return $word
4735}
4736
4737
4738# return text action beginning with $text
4739proc complete_action { text state } {   
4740    global action_array complete_choices complete_position
4741
4742    if {$state == 0} {
4743        set complete_position 0
4744        set complete_choices [array names action_array "[string tolower $text]*"]
4745    }
4746
4747    set word [lindex $complete_choices $complete_position]
4748    incr complete_position
4749
4750    return $word
4751}
4752
4753# return all actions beginning with $text
4754proc guess_action { text } {   
4755    global action_array
4756
4757    return [array names action_array "[string tolower $text]*"]
4758
4759    if { [llength $complete_choices ] == 1 } {
4760        return [lindex $complete_choices 0]
4761    }
4762
4763    return {}
4764}
4765
4766proc attempt_completion { text word start end } {
4767    # If the word starts with '~', or contains '.' or '/', then use the build-in
4768    # completion to complete the word
4769    if { [regexp {^~|[/.]} $word] } {
4770        return ""
4771    }
4772
4773    # Decide how to do completion based on where we are in the string
4774    set prefix [string range $text 0 [expr {$start - 1}]]
4775   
4776    # If only whitespace characters preceed us, or if the
4777    # previous non-whitespace character was a ;, then we're
4778    # an action (the first word of a command)
4779    if { [regexp {(^\s*$)|(;\s*$)} $prefix] } {
4780        return complete_action
4781    }
4782   
4783    # Otherwise, do completion on portname
4784    return complete_portname
4785}
4786
4787
4788proc get_next_cmdline { in out use_readline prompt linename } {
4789    upvar $linename line
4790   
4791    set line ""
4792    while { $line eq "" } {
4793
4794        if {$use_readline} {
4795            set len [readline read -attempted_completion attempt_completion line $prompt]
4796        } else {
4797            puts -nonewline $out $prompt
4798            flush $out
4799            set len [gets $in line]
4800        }
4801
4802        if { $len < 0 } {
4803            return -1
4804        }
4805       
4806        set line [string trim $line]
4807
4808        if { $use_readline && $line ne "" } {
4809            rl_history add $line
4810        }
4811    }
4812   
4813    return [llength $line]
4814}
4815
4816
4817proc process_command_file { in } {
4818    global current_portdir
4819
4820    # Initialize readline
4821    set isstdin [string match $in "stdin"]
4822    set name "port"
4823    set use_readline [expr {$isstdin && [readline init $name]}]
4824    set history_file [file normalize "${macports::macports_user_dir}/history"]
4825
4826    # Read readline history
4827    if {$use_readline && [file isdirectory $macports::macports_user_dir]} {
4828        rl_history read $history_file
4829        rl_history stifle 100
4830    }
4831
4832    # Be noisy, if appropriate
4833    set noisy [expr $isstdin && ![macports::ui_isset ports_quiet]]
4834    if { $noisy } {
4835        puts "MacPorts [macports::version]"
4836        puts "Entering interactive mode... (\"help\" for help, \"quit\" to quit)"
4837    }
4838
4839    # Main command loop
4840    set exit_status 0
4841    while { $exit_status == 0 || $isstdin || [macports::ui_isset ports_processall] } {
4842
4843        # Calculate our prompt
4844        if { $noisy } {
4845            set shortdir [file join {*}[lrange [file split $current_portdir] end-1 end]]
4846            set prompt "\[$shortdir\] > "
4847        } else {
4848            set prompt ""
4849        }
4850
4851        # Get a command line
4852        if { [get_next_cmdline $in stdout $use_readline $prompt line] <= 0  } {
4853            puts ""
4854            break
4855        }
4856
4857        # Process the command
4858        set exit_status [process_cmd $line]
4859       
4860        # Check for semaphore to exit
4861        if {$exit_status == -999} {
4862            set exit_status 0
4863            break
4864        }
4865    }
4866
4867    # Create macports user directory if it does not exist yet
4868    if {$use_readline && ![file isdirectory $macports::macports_user_dir]} {
4869        file mkdir $macports::macports_user_dir
4870    }
4871    # Save readine history
4872    if {$use_readline && [file isdirectory $macports::macports_user_dir]} {
4873        rl_history write $history_file
4874    }
4875
4876    # Say goodbye
4877    if { $noisy } {
4878        puts "Goodbye"
4879    }
4880
4881    return $exit_status
4882}
4883
4884
4885proc process_command_files { filelist } {
4886    set exit_status 0
4887
4888    # For each file in the command list, process commands
4889    # in the file
4890    foreach file $filelist {
4891        if {$file eq "-"} {
4892            set in stdin
4893        } else {
4894            if {[catch {set in [open $file]} result]} {
4895                fatal "Failed to open command file; $result"
4896            }
4897        }
4898
4899        set exit_status [process_command_file $in]
4900
4901        if {$in ne "stdin"} {
4902            close $in
4903        }
4904
4905        # Exit on first failure unless -p was given
4906        if {$exit_status != 0 && ![macports::ui_isset ports_processall]} {
4907            return $exit_status
4908        }
4909    }
4910
4911    return $exit_status
4912}
4913
4914namespace eval portclient::progress {
4915    ##
4916    # Maximum width of the progress bar or indicator when displaying it.
4917    variable maxWidth 50
4918
4919    ##
4920    # The start time of the last progress callback as returned by [clock time].
4921    # Since only one progress indicator is active at a time, this variable is
4922    # shared between the different variants of progress functions.
4923    variable startTime
4924
4925    ##
4926    # Delay in milliseconds after the start of the operation before deciding
4927    # that showing a progress bar makes sense.
4928    variable showTimeThreshold 500
4929
4930    ##
4931    # Percentage value between 0 and 1 that must not have been reached yet when
4932    # $showTimeThreshold has passed for a progress bar to be shown. If the
4933    # operation has proceeded above e.g. 75% after 500ms we won't bother
4934    # displaying a progress indicator anymore -- the operation will be finished
4935    # in well below a second anyway.
4936    variable showPercentageThreshold 0.75
4937
4938    ##
4939    # Boolean indication whether the progress indicator should be shown or is
4940    # still hidden because the current operation didn't need enough time for
4941    # a progress indicator to make sense, yet.
4942    variable show no
4943
4944    ##
4945    # Initialize the progress bar display delay; call this from the start
4946    # action of the progress functions.
4947    proc initDelay {} {
4948        variable show
4949        variable startTime
4950
4951        set startTime [clock milliseconds]
4952        set show no
4953    }
4954
4955    ##
4956    # Determine whether a progress bar should be shown for the current
4957    # operation in its current state. You must have called initDelay for the
4958    # current operation before calling this method.
4959    #
4960    # @param cur
4961    #        Current progress in abstract units.
4962    # @param total
4963    #        Total number of abstract units to be processed, if known. Pass
4964    #        0 if unknown.
4965    # @return
4966    #        "yes", if the progress indicator should be shown, "no" otherwise.
4967    proc showProgress {cur total} {
4968        variable show
4969        variable startTime
4970        variable showTimeThreshold
4971        variable showPercentageThreshold
4972
4973        if {$show eq "yes"} {
4974            return yes
4975        } else {
4976            if {[expr {[clock milliseconds] - $startTime}] > $showTimeThreshold &&
4977                ($total == 0 || [expr {double($cur) / double($total)}] < $showPercentageThreshold)} {
4978                set show yes
4979            }
4980            return $show
4981        }
4982    }
4983
4984    ##
4985    # Progress callback for generic operations executed by macports 1.0.
4986    #
4987    # @param action
4988    #        One of "start", "update", "intermission" or "finish", where start
4989    #        will be called before any number of update calls, interrupted by
4990    #        any number of intermission calls (called because other output is
4991    #        being produced), followed by one call to finish.
4992    # @param args
4993    #        A list of variadic args that differ for each action. For "start",
4994    #        "intermission" and "finish", the args are empty and unused. For
4995    #        "update", args contains $cur and $total, where $cur is the current
4996    #        number of units processed and $total is the total number of units
4997    #        to be processed. If the total is not known, it is 0.
4998    proc generic {action args} {
4999        global env
5000        variable maxWidth
5001
5002        switch -nocase -- $action {
5003            start {
5004                initDelay
5005            }
5006            update {
5007                # the for loop is a simple hack because Tcl 8.4 doesn't have
5008                # lassign
5009                foreach {now total} $args {
5010                    if {[showProgress $now $total] eq "yes"} {
5011                        set barPrefix "      "
5012                        set barPrefixLen [string length $barPrefix]
5013                        if {$total != 0} {
5014                            progressbar $now $total [expr {min($maxWidth, $env(COLUMNS) - $barPrefixLen)}] $barPrefix
5015                        } else {
5016                            unprogressbar [expr {min($maxWidth, $env(COLUMNS) - $barPrefixLen)}] $barPrefix
5017                        }
5018                    }
5019                }
5020            }
5021            intermission -
5022            finish {
5023                # erase to start of line
5024                ::term::ansi::send::esol
5025                # return cursor to start of line
5026                puts -nonewline "\r"
5027                flush stdout
5028            }
5029        }
5030
5031        return 0
5032    }
5033
5034    ##
5035    # Progress callback for downloads executed by macports 1.0.
5036    #
5037    # This is essentially a cURL progress callback.
5038    #
5039    # @param action
5040    #        One of "start", "update" or "finish", where start will be called
5041    #        before any number of update calls, followed by one call to finish.
5042    # @param args
5043    #        A list of variadic args that differ for each action. For "start",
5044    #        contains a single argument "ul" or "dl" indicating whether this is
5045    #        an up- or download. For "update", contains the arguments
5046    #        ("ul"|"dl") $total $now $speed where ul/dl are as for start, and
5047    #        total, now and speed are doubles indicating the total transfer
5048    #        size, currently transferred amount and average speed per second in
5049    #        bytes. Unused for "finish".
5050    proc download {action args} {
5051        global env
5052        variable maxWidth
5053
5054        switch -nocase -- $action {
5055            start {
5056                initDelay
5057            }
5058            update {
5059                # the for loop is a simple hack because Tcl 8.4 doesn't have
5060                # lassign
5061                foreach {type total now speed} $args {
5062                    if {[showProgress $now $total] eq "yes"} {
5063                        set barPrefix "      "
5064                        set barPrefixLen [string length $barPrefix]
5065                        if {$total != 0} {
5066                            set barSuffix [format "        speed: %-13s" "[bytesize $speed {} "%.1f"]/s"]
5067                            set barSuffixLen [string length $barSuffix]
5068
5069                            set barLen [expr {min($maxWidth, $env(COLUMNS) - $barPrefixLen - $barSuffixLen)}]
5070                            progressbar $now $total $barLen $barPrefix $barSuffix
5071                        } else {
5072                            set barSuffix [format " %-10s     speed: %-13s" [bytesize $now {} "%6.1f"] "[bytesize $speed {} "%.1f"]/s"]
5073                            set barSuffixLen [string length $barSuffix]
5074
5075                            set barLen [expr {min($maxWidth, $env(COLUMNS) - $barPrefixLen - $barSuffixLen)}]
5076                            unprogressbar $barLen $barPrefix $barSuffix
5077                        }
5078                    }
5079                }
5080            }
5081            finish {
5082                # erase to start of line
5083                ::term::ansi::send::esol
5084                # return cursor to start of line
5085                puts -nonewline "\r"
5086                flush stdout
5087            }
5088        }
5089
5090        return 0
5091    }
5092
5093    ##
5094    # Draw a progress bar using unicode block drawing characters
5095    #
5096    # @param current
5097    #        The current progress value.
5098    # @param total
5099    #        The progress value representing 100%.
5100    # @param width
5101    #        The width in characters of the progress bar. This includes percentage
5102    #        output, which takes up 8 characters.
5103    # @param prefix
5104    #        Prefix to be printed in front of the progress bar.
5105    # @param suffix
5106    #        Suffix to be printed after the progress bar.
5107    proc progressbar {current total width {prefix ""} {suffix ""}} {
5108        # Subtract the width of the percentage output, also subtract the two
5109        # characters [ and ] bounding the progress bar.
5110        set percentageWidth 8
5111        set barWidth      [expr {entier($width) - $percentageWidth - 2}]
5112
5113        # Map the range (0, $total) to (0, 4 * $width) where $width is the maximum
5114        # numebr of characters to be printed for the progress bar. Multiply the
5115        # upper bound with 8 because we have 8 sub-states per character.
5116        set barProgress   [expr {entier(round(($current * $barWidth * 8) / $total))}]
5117
5118        set barInteger    [expr {$barProgress / 8}]
5119        #set barRemainder  [expr {$barProgress % 8}]
5120
5121        # Finally, also provide a percentage value to print behind the progress bar
5122        set percentage [expr {double($current) * 100 / double($total)}]
5123
5124        # clear the current line, enable reverse video
5125        set progressbar "\033\[7m"
5126        for {set i 0} {$i < $barInteger} {incr i} {
5127            # U+2588 FULL BLOCK doesn't match the other blocks in some fonts :/
5128            # Two half blocks work better in some fonts, but not in others (because
5129            # they leave ugly spaces). So, one or the other choice isn't better or
5130            # worse and even just using full blocks looks ugly in a few fonts.
5131
5132            # Use pure ASCII until somebody fixes most of the default terminal fonts :/
5133            append progressbar " "
5134        }
5135        # back to normal output
5136        append progressbar "\033\[0m"
5137
5138        #switch $barRemainder {
5139        #    0 {
5140        #        if {$barInteger < $barWidth} {
5141        #            append progressbar " "
5142        #        }
5143        #    }
5144        #    1 {
5145        #        # U+258F LEFT ONE EIGHTH BLOCK
5146        #        append progressbar "\u258f"
5147        #    }
5148        #    2 {
5149        #        # U+258E LEFT ONE QUARTER BLOCK
5150        #        append progressbar "\u258e"
5151        #    }
5152        #    3 {
5153        #        # U+258D LEFT THREE EIGHTHS BLOCK
5154        #        append progressbar "\u258d"
5155        #    }
5156        #    3 {
5157        #        # U+258D LEFT THREE EIGHTHS BLOCK
5158        #        append progressbar "\u258d"
5159        #    }
5160        #    4 {
5161        #        # U+258C LEFT HALF BLOCK
5162        #        append progressbar "\u258c"
5163        #    }
5164        #    5 {
5165        #        # U+258B LEFT FIVE EIGHTHS BLOCK
5166        #        append progressbar "\u258b"
5167        #    }
5168        #    6 {
5169        #        # U+258A LEFT THREE QUARTERS BLOCK
5170        #        append progressbar "\u258a"
5171        #    }
5172        #    7 {
5173        #        # U+2589 LEFT SEVEN EIGHTHS BLOCK
5174        #        append progressbar "\u2589"
5175        #    }
5176        #}
5177
5178        # Fill the progress bar with spaces
5179        for {set i $barInteger} {$i < $barWidth} {incr i} {
5180            append progressbar " "
5181        }
5182
5183        # Format the percentage using the space that has been reserved for it
5184        set percentagesuffix [format " %[expr {$percentageWidth - 3}].1f %%" $percentage]
5185
5186        puts -nonewline "\r${prefix}\[${progressbar}\]${percentagesuffix}${suffix}"
5187        flush stdout
5188    }
5189
5190
5191    ##
5192    # Internal state of the progress indicator; unless you're hacking the
5193    # unprogressbar code you should never touch this.
5194    variable unprogressState 0
5195
5196    ##
5197    # Draw a progress indicator
5198    #
5199    # @param width
5200    #        The width in characters of the progress indicator.
5201    # @param prefix
5202    #        Prefix to be printed in front of the progress indicator.
5203    # @param suffix
5204    #        Suffix to be printed after the progress indicator.
5205    proc unprogressbar {width {prefix ""} {suffix ""}} {
5206        variable unprogressState
5207
5208        # Subtract the two characters [ and ] bounding the progress indicator
5209        # from the width.
5210        set barWidth [expr {int($width) - 2}]
5211
5212        # Number of states of the progress bar, or rather: the number of
5213        # characters before the sequence repeats.
5214        set numStates 4
5215
5216        set unprogressState [expr {($unprogressState + 1) % $numStates}]
5217
5218        set progressbar ""
5219        for {set i 0} {$i < $barWidth} {incr i} {
5220            if {[expr {$i % $numStates}] == $unprogressState} {
5221                # U+2022 BULLET
5222                append progressbar "\u2022"
5223            } else {
5224                append progressbar " "
5225            }
5226        }
5227
5228        puts -nonewline "\r${prefix}\[${progressbar}\]${suffix}"
5229        flush stdout
5230    }
5231}
5232
5233namespace eval portclient::notifications {
5234    ##
5235    # Ports whose notifications to display; these were either installed
5236    # or requested to be installed.
5237    variable notificationsToPrint
5238    array set notificationsToPrint {}
5239
5240    ##
5241    # Add a port to the list for printing notifications.
5242    #
5243    # @param name
5244    #        The name of the port.
5245    # @param note
5246    #        A list of notes to be stored for the given port.
5247    proc append {name notes} {
5248        variable notificationsToPrint
5249
5250        set notificationsToPrint($name) $notes
5251    }
5252
5253    ##
5254    # Print port notifications.
5255    #
5256    proc display {} {
5257        global env
5258        variable notificationsToPrint
5259
5260        # Display notes at the end of the activation phase.
5261        if {[array size notificationsToPrint] > 0} {
5262            ui_notice "--->  Some of the ports you installed have notes:"
5263            foreach name [lsort [array names notificationsToPrint]] {
5264                set notes $notificationsToPrint($name)
5265                ui_notice "  $name has the following notes:"
5266
5267                # If env(COLUMNS) exists, limit each line's width to this width.
5268                if {[info exists env(COLUMNS)]} {
5269                    set maxlen $env(COLUMNS)
5270
5271                    foreach note $notes {
5272                        foreach line [split $note "\n"] {
5273                            set joiner ""
5274                            set lines ""
5275                            set newline "    "
5276
5277                            foreach word [split $line " "] {
5278                                if {[string length $newline] + [string length $word] >= $maxlen} {
5279                                    lappend lines $newline
5280                                    set newline "    "
5281                                    set joiner ""
5282                                }
5283                                ::append newline $joiner $word
5284                                set joiner " "
5285                            }
5286                            if {$newline ne {}} {
5287                                lappend lines $newline
5288                            }
5289                            ui_notice [join $lines "\n"]
5290                        }
5291                    }
5292                } else {
5293                    foreach note $notes {
5294                        ui_notice $note
5295                    }
5296                }
5297            }
5298        }
5299    }
5300}
5301
5302# Create namespace for questions
5303namespace eval portclient::questions {
5304       
5305        package require Tclx
5306        ##
5307        # Function that handles printing of a timeout.
5308        #
5309        # @param time
5310        #        The amount of time for which a timeout is to occur.
5311        # @param def
5312        #        The default action to be taken in the occurence of a timeout.
5313        proc ui_timeout {def timeout} {
5314                fconfigure stdin -blocking 0
5315
5316                signal error {TERM INT}
5317                while {$timeout >= 0} {
5318                        if {[catch {set inp [read stdin]} err]} {
5319                                return -code error "Ctrl-C"
5320                        }
5321                        if {$inp eq "\n"} {
5322                                return $def
5323                        }
5324                        puts -nonewline "\r"
5325                        puts -nonewline [format "Continuing in %02d s. Press Ctrl-C to exit: " $timeout]
5326                        flush stdout
5327                        after 1000
5328                        incr timeout -1
5329                }
5330                puts ""
5331                fconfigure stdin -blocking 1
5332                signal -restart error {TERM INT}
5333                return $def
5334        }
5335       
5336        ##
5337        # Main function that displays numbered choices for a multiple choice question.
5338        #
5339        # @param msg
5340        #        The question specific message that is to be printed before asking the question.
5341        # @param ???name???
5342        #        May be a qid will be of better use instead as the client does not do anything port specific.
5343        # @param ports
5344        #        The list of ports for which the question is being asked.
5345        proc ui_choice {msg name ports} {
5346                # Print the main message
5347                puts $msg
5348               
5349                # Print portname or port list suitably
5350                set i 1
5351                foreach port $ports {
5352                        puts -nonewline " $i) "
5353                        puts [string map {@ " @" ( " ("} $port]
5354                        incr i
5355                }
5356        }
5357       
5358        ##
5359        # Displays a question with 'yes' and 'no' as options.
5360        # Waits for user input indefinitely unless a timeout is specified.
5361        # Shows the list of port passed to it without any numbers.
5362        #
5363        # @param msg
5364        #        The question specific message that is to be printed before asking the question.
5365        # @param ???name???
5366        #        May be a qid will be of better use instead as the client does not do anything port specific.
5367        # @param ports
5368        #        The port/list of ports for which the question is being asked.
5369        # @param def
5370        #        The default answer to the question.
5371        # @param time
5372        #                The amount of time for which a timeout is to occur.
5373        proc ui_ask_yesno {msg name ports def {timeout 0}} {
5374                # Set number default to the given letter default
5375                if {$def == {y}} {
5376                        set default 0
5377                } else {
5378                        set default 1
5379                }
5380               
5381                puts -nonewline $msg
5382                set leftmargin " "
5383               
5384                # Print portname or port list suitably
5385                if {[llength $ports] == 1} {
5386                        puts -nonewline " "
5387                        puts [string map {@ " @"} $ports]
5388                } else {
5389                        puts ""
5390                        foreach port $ports {
5391                                puts -nonewline $leftmargin 
5392                                puts [string map {@ " @"} $port]
5393                        }
5394                }
5395               
5396                # Check if timeout is set or not
5397                if {$timeout > 0} {
5398                        # Run ui_timeout and skip the rest of the stuff here
5399                        return [ui_timeout $default $timeout] 
5400                }
5401                               
5402                # Check for the default and print accordingly
5403                if {$def == {y}} {
5404                        puts -nonewline "Continue? \[Y/n\]: "
5405                        flush stdout
5406                } else {
5407                        puts -nonewline "Continue? \[y/N\]: "
5408                        flush stdout
5409                }
5410               
5411                # User input (probably requires some input error checking code)
5412                while 1 {
5413                        signal error {TERM INT}
5414                        if {[catch {set input [gets stdin]} err]} {
5415                                return -code error "Ctrl-C"
5416                        }
5417                        signal -restart error {TERM INT}
5418                        if {$input in {y Y}} {
5419                                return 0
5420                        } elseif {$input in {n N}} {
5421                                return 1
5422                        } elseif {$input == ""} {
5423                                return $default
5424                        } else {
5425                                puts "Please enter either 'y' or 'n'."
5426                        }
5427                }
5428        }
5429       
5430        ##
5431        # Displays a question with a list of numbered choices and asks the user to enter a number to specify their choice.
5432        # Waits for user input indefinitely.
5433        #
5434        # @param msg
5435        #        The question specific message that is to be printed before asking the question.
5436        # @param ???name???
5437        #        May be a qid will be of better use instead as the client does not do anything port specific.
5438        # @param ports
5439        #        The port/list of ports for which the question is being asked.
5440        proc ui_ask_singlechoice {msg name ports} {
5441                ui_choice $msg $name $ports
5442                               
5443                # User Input (single input restriction)
5444                while 1 {
5445                        puts -nonewline "Enter a number to select an option: "
5446                        flush stdout
5447                        signal error {TERM INT}
5448                        if {[catch {set input [gets stdin]} err]} {
5449                                return -code error "Ctrl-C"
5450                        }
5451                        signal -restart error {TERM INT}
5452                        if {($input <= [llength $ports] && [string is integer -strict $input])} {
5453                                return $input
5454                        } else {
5455                                puts "Please enter an index from the above list."
5456                        }
5457                }
5458        }
5459       
5460        ##
5461        # Displays a question with a list of numbered choices and asks the user to enter a space separated string of numbers to specify their choice.
5462        # Waits for user input indefinitely.
5463        #
5464        # @param msg
5465        #        The question specific message that is to be printed before asking the question.
5466        # @param ???name???
5467        #        May be a qid will be of better use instead as the client does not do anything port specific.
5468        # @param ports
5469        #        The list of ports for which the question is being asked.
5470        proc ui_ask_multichoice {msg name ports} {
5471               
5472                ui_choice $msg $name $ports
5473                               
5474                # User Input (with Multiple input parsing)
5475                while 1 {
5476                        puts -nonewline "Enter the numbers to select the options: "
5477                        flush stdout
5478                        signal error {TERM INT}
5479                        if {[catch {set input [gets stdin]} err]} {
5480                                return -code error "Ctrl-C"
5481                        }
5482                        signal -restart error {TERM INT}
5483                        set count 0
5484                        # check if input is non-empty and otherwise fine
5485                        if {$input == ""} {
5486                                continue
5487                        }
5488                        foreach num $input {
5489                                if {($num <= [llength $ports] && [string is integer -strict $num])} {
5490                                        incr count
5491                                } else {
5492                                        puts "Please enter numbers separated by a space which are indices from the above list."
5493                                        break
5494                                }
5495                        }
5496                        if {$count == [llength $input]} {
5497                                return $input
5498                        }
5499                }
5500        }
5501}
5502
5503##########################################
5504# Main
5505##########################################
5506
5507# Global arrays passed to the macports1.0 layer
5508array set ui_options        {}
5509array set global_options    {}
5510array set global_variations {}
5511
5512# Global options private to this script
5513array set private_options {}
5514
5515# Make sure we get the size of the terminal
5516# We do this here to save it in the boot_env, in case we determined it manually
5517term_init_size
5518
5519global env boot_env argv0 cmdname argc argv cmd_argc cmd_argv cmd_argn \
5520       current_portdir global_options_base exit_status
5521
5522# Save off a copy of the environment before mportinit monkeys with it
5523array set boot_env [array get env]
5524
5525set cmdname [file tail $argv0]
5526
5527# Setp cmd_argv to match argv
5528set cmd_argv $argv
5529set cmd_argc $argc
5530set cmd_argn 0
5531
5532# make sure we're using a sane umask
5533umask 022
5534
5535# If we've been invoked as portf, then the first argument is assumed
5536# to be the name of a command file (i.e., there is an implicit -F
5537# before any arguments).
5538if {[moreargs] && $cmdname eq "portf"} {
5539    lappend ui_options(ports_commandfiles) [lookahead]
5540    advance
5541}
5542
5543# Parse global options that will affect all subsequent commands
5544if {[catch {parse_options "global" ui_options global_options} result]} {
5545    puts "Error: $result"
5546    print_usage
5547    exit 1
5548}
5549
5550if {[isatty stdout]
5551    && $portclient::progress::hasTermAnsiSend eq "yes"
5552    && (![info exists ui_options(ports_quiet)] || $ui_options(ports_quiet) ne "yes")} {
5553    set ui_options(progress_download) portclient::progress::download
5554    set ui_options(progress_generic)  portclient::progress::generic
5555}
5556
5557if {[isatty stdin]
5558        && [isatty stdout]
5559        && (![info exists ui_options(ports_quiet)] || $ui_options(ports_quiet) ne "yes")
5560        && (![info exists ui_options(ports_noninteractive)] || $ui_options(ports_noninteractive) ne "yes")} {
5561        set ui_options(questions_yesno) portclient::questions::ui_ask_yesno
5562        set ui_options(questions_singlechoice) portclient::questions::ui_ask_singlechoice
5563        set ui_options(questions_multichoice) portclient::questions::ui_ask_multichoice
5564}
5565
5566set ui_options(notifications_append) portclient::notifications::append
5567
5568# Get arguments remaining after option processing
5569set remaining_args [lrange $cmd_argv $cmd_argn end]
5570
5571# If we have no arguments remaining after option processing then force
5572# interactive mode
5573if { [llength $remaining_args] == 0 && ![info exists ui_options(ports_commandfiles)] } {
5574    lappend ui_options(ports_commandfiles) -
5575} elseif {[lookahead] eq "selfupdate" || [lookahead] eq "sync"} {
5576    # tell mportinit not to tell the user they should selfupdate
5577    set ui_options(ports_no_old_index_warning) 1
5578}
5579
5580# Initialize mport
5581# This must be done following parse of global options, as some options are
5582# evaluated by mportinit.
5583if {[catch {mportinit ui_options global_options global_variations} result]} {
5584    global errorInfo
5585    puts "$errorInfo"
5586    fatal "Failed to initialize MacPorts, $result"
5587}
5588
5589# Set up some global state for our code
5590set current_portdir [pwd]
5591
5592# Freeze global_options into global_options_base; global_options
5593# will be reset to global_options_base prior to processing each command.
5594set global_options_base [array get global_options]
5595
5596# First process any remaining args as action(s)
5597set exit_status 0
5598if { [llength $remaining_args] > 0 } {
5599
5600    # If there are remaining arguments, process those as a command
5601    set exit_status [process_cmd $remaining_args]
5602}
5603
5604# Process any prescribed command files, including standard input
5605if { ($exit_status == 0 || [macports::ui_isset ports_processall]) && [info exists ui_options(ports_commandfiles)] } {
5606    set exit_status [process_command_files $ui_options(ports_commandfiles)]
5607}
5608if {$exit_status == -999} {
5609    set exit_status 0
5610}
5611
5612# shut down macports1.0
5613mportshutdown
5614
5615# Return with exit_status
5616exit $exit_status
Note: See TracBrowser for help on using the repository browser.