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

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

remove obsolete PortInfo(variant_desc)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 189.2 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 133649 2015-03-08 00:23:53Z jmr@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 variant info if it exists.
3571            if {[info exists portinfo(vinfo)]} {
3572                array set vinfo $portinfo(vinfo)
3573            }
3574
3575            # print out all the variants
3576            ui_notice "$portname has the variants:"
3577            foreach v [lsort $portinfo(variants)] {
3578                unset -nocomplain vconflicts vdescription vrequires
3579                set varmodifier "   "
3580                # Retrieve variants' information from the new format.
3581                if {[info exists vinfo]} {
3582                    array unset variant
3583                    array set variant $vinfo($v)
3584
3585                    # Retrieve conflicts, description, is_default, and
3586                    # vrequires.
3587                    if {[info exists variant(conflicts)]} {
3588                        set vconflicts $variant(conflicts)
3589                    }
3590                    if {[info exists variant(description)]} {
3591                        set vdescription $variant(description)
3592                    }
3593
3594                    # XXX Keep these varmodifiers in sync with action_info, or create a wrapper for it
3595                    if {[info exists variations($v)]} {
3596                        set varmodifier "  $variations($v)"
3597                    } elseif {[info exists global_variations($v)]} {
3598                        # selected by variants.conf, prefixed with (+)/(-)
3599                        set varmodifier "($global_variations($v))"
3600                    } elseif {[info exists variant(is_default)]} {
3601                        set varmodifier "\[$variant(is_default)\]"
3602                    }
3603                    if {[info exists variant(requires)]} {
3604                        set vrequires $variant(requires)
3605                    }
3606                }
3607
3608                if {[info exists vdescription]} {
3609                    puts [wraplabel "$varmodifier$v" [string trim $vdescription] 0 [string repeat " " [expr 5 + [string length $v]]]]
3610                } else {
3611                    puts "$varmodifier$v"
3612                }
3613                if {[info exists vconflicts]} {
3614                    puts "     * conflicts with [string trim $vconflicts]"
3615                }
3616                if {[info exists vrequires]} {
3617                    puts "     * requires [string trim $vrequires]"
3618                }
3619            }
3620        }
3621    }
3622
3623    return $status
3624}
3625
3626
3627proc action_search { action portlist opts } {
3628    global private_options global_options
3629    set status 0
3630    if {![llength $portlist] && [info exists private_options(ports_no_args)] && $private_options(ports_no_args) eq "yes"} {
3631        ui_error "You must specify a search pattern"
3632        return 1
3633    }
3634
3635    # Copy global options as we are going to modify the array
3636    array set options [array get global_options]
3637
3638    if {[info exists options(ports_search_depends)] && $options(ports_search_depends) eq "yes"} {
3639        array unset options ports_search_depends
3640        set options(ports_search_depends_fetch) yes
3641        set options(ports_search_depends_extract) yes
3642        set options(ports_search_depends_build) yes
3643        set options(ports_search_depends_lib) yes
3644        set options(ports_search_depends_run) yes
3645    }
3646
3647    # Array to hold given filters
3648    array set filters {}
3649    # Default matchstyle
3650    set filter_matchstyle "none"
3651    set filter_case no
3652    foreach { option } [array names options ports_search_*] {
3653        set opt [string range $option 13 end]
3654
3655        if { $options($option) ne "yes" } {
3656            continue
3657        }
3658        switch -- $opt {
3659            exact -
3660            glob {
3661                set filter_matchstyle $opt
3662                continue
3663            }
3664            regex {
3665                set filter_matchstyle regexp
3666                continue
3667            }
3668            case-sensitive {
3669                set filter_case yes
3670                continue
3671            }
3672            line {
3673                continue
3674            }
3675        }
3676
3677        set filters($opt) "yes"
3678    }
3679    # Set default search filter if none was given
3680    if { [array size filters] == 0 } {
3681        set filters(name) "yes"
3682        set filters(description) "yes"
3683    }
3684
3685    set separator ""
3686    foreach portname $portlist {
3687        puts -nonewline $separator
3688
3689        set searchstring $portname
3690        set matchstyle $filter_matchstyle
3691        if {$matchstyle eq "none"} {
3692            # Guess if the given string was a glob expression, if not do a substring search
3693            if {[string first "*" $portname] == -1 && [string first "?" $portname] == -1} {
3694                set searchstring "*$portname*"
3695            }
3696            set matchstyle glob
3697        }
3698
3699        set res {}
3700        set portfound 0
3701        foreach { opt } [array get filters] {
3702            # Map from friendly name
3703            set opt [map_friendly_field_names $opt]
3704
3705            if {[catch {set matches [mportsearch $searchstring $filter_case $matchstyle $opt]} result]} {
3706                global errorInfo
3707                ui_debug "$errorInfo"
3708                break_softcontinue "search for name $portname failed: $result" 1 status
3709            }
3710
3711            set tmp {}
3712            foreach {name info} $matches {
3713                add_to_portlist tmp [concat [list name $name] $info]
3714            }
3715            set res [opUnion $res $tmp]
3716        }
3717        set res [portlist_sort $res]
3718
3719        set joiner ""
3720        foreach info $res {
3721            array unset portinfo
3722            array set portinfo $info
3723
3724            # XXX is this the right place to verify an entry?
3725            if {![info exists portinfo(name)]} {
3726                puts stderr "Invalid port entry, missing portname"
3727                continue
3728            }
3729            if {![info exists portinfo(description)]} {
3730                puts stderr "Invalid port entry for $portinfo(name), missing description"
3731                continue
3732            }
3733            if {![info exists portinfo(version)]} {
3734                puts stderr "Invalid port entry for $portinfo(name), missing version"
3735                continue
3736            }
3737
3738            if {[macports::ui_isset ports_quiet]} {
3739                puts $portinfo(name)
3740            } else {
3741                if {[info exists options(ports_search_line)]
3742                        && $options(ports_search_line) eq "yes"} {
3743                    # check for ports without category, e.g. replaced_by stubs
3744                    if {[info exists portinfo(categories)]} {
3745                        puts "$portinfo(name)\t$portinfo(version)\t$portinfo(categories)\t$portinfo(description)"
3746                    } else {
3747                        # keep two consecutive tabs in order to provide consistent columns' content
3748                        puts "$portinfo(name)\t$portinfo(version)\t\t$portinfo(description)"
3749                    }
3750                } else {
3751                    puts -nonewline $joiner
3752
3753                    puts -nonewline "$portinfo(name) @$portinfo(version)"
3754                    if {[info exists portinfo(revision)] && $portinfo(revision) > 0} {
3755                        puts -nonewline "_$portinfo(revision)"
3756                    }
3757                    if {[info exists portinfo(categories)]} {
3758                        puts -nonewline " ([join $portinfo(categories) ", "])"
3759                    }
3760                    puts ""
3761                    puts [wrap [join $portinfo(description)] 0 [string repeat " " 4]]
3762                }
3763            }
3764
3765            set joiner "\n"
3766            set portfound 1
3767        }
3768        if { !$portfound } {
3769            ui_notice "No match for $portname found"
3770        } elseif {[llength $res] > 1} {
3771            if {(![info exists global_options(ports_search_line)]
3772                    || $global_options(ports_search_line) ne "yes")} {
3773                ui_notice "\nFound [llength $res] ports."
3774            }
3775        }
3776
3777        set separator "--\n"
3778    }
3779
3780    array unset options
3781    array unset filters
3782
3783    return $status
3784}
3785
3786
3787proc action_list { action portlist opts } {
3788    global private_options
3789    set status 0
3790   
3791    # Default to list all ports if no portnames are supplied
3792    if { ![llength $portlist] && [info exists private_options(ports_no_args)] && $private_options(ports_no_args) eq "yes"} {
3793        add_to_portlist portlist [list name "-all-"]
3794    }
3795   
3796    foreachport $portlist {
3797        if {$portname eq "-all-"} {
3798           if {[catch {set res [mportlistall]} result]} {
3799                global errorInfo
3800                ui_debug "$errorInfo"
3801                break_softcontinue "listing all ports failed: $result" 1 status
3802            }
3803        } else {
3804            if {$portversion ne "" && ![info exists warned_for_version]} {
3805                ui_warn "The 'list' action only shows the currently available version of each port. To see installed versions, use the 'installed' action."
3806                set warned_for_version 1
3807            }
3808            set search_string [regex_pat_sanitize $portname]
3809            if {[catch {set res [mportsearch ^$search_string\$ no]} result]} {
3810                global errorInfo
3811                ui_debug "$errorInfo"
3812                break_softcontinue "search for portname $search_string failed: $result" 1 status
3813            }
3814        }
3815
3816        foreach {name array} $res {
3817            array unset portinfo
3818            array set portinfo $array
3819            set outdir ""
3820            if {[info exists portinfo(portdir)]} {
3821                set outdir $portinfo(portdir)
3822            }
3823            puts [format "%-30s @%-14s %s" $portinfo(name) $portinfo(version) $outdir]
3824        }
3825    }
3826   
3827    return $status
3828}
3829
3830
3831proc action_echo { action portlist opts } {
3832    global global_options
3833
3834    # Simply echo back the port specs given to this command
3835    foreachport $portlist {
3836        if {![macports::ui_isset ports_quiet]} {
3837            set opts {}
3838            foreach { key value } [array get options] {
3839                if {![info exists global_options($key)]} {
3840                    lappend opts "$key=$value"
3841                }
3842            }
3843
3844            set composite_version [composite_version $portversion [array get variations] 1]
3845            if { $composite_version ne "" } {
3846                set ver_field "@$composite_version"
3847            } else {
3848                set ver_field ""
3849            }
3850            puts [format "%-30s %s %s" $portname $ver_field  [join $opts " "]]
3851        } else {
3852            puts "$portname"
3853        }
3854    }
3855
3856    return 0
3857}
3858
3859
3860proc action_portcmds { action portlist opts } {
3861    # Operations on the port's directory and Portfile
3862    global env boot_env current_portdir
3863
3864    array set local_options $opts
3865   
3866    set status 0
3867    if {[require_portlist portlist]} {
3868        return 1
3869    }
3870    foreachport $portlist {
3871        array unset portinfo
3872        # If we have a url, use that, since it's most specific, otherwise try to map the portname to a url
3873        if {$porturl eq ""} {
3874       
3875            # Verify the portname, getting portinfo to map to a porturl
3876            if {[catch {set res [mportlookup $portname]} result]} {
3877                global errorInfo
3878                ui_debug "$errorInfo"
3879                break_softcontinue "lookup of portname $portname failed: $result" 1 status
3880            }
3881            if {[llength $res] < 2} {
3882                break_softcontinue "Port $portname not found" 1 status
3883            }
3884            array set portinfo [lindex $res 1]
3885            set porturl $portinfo(porturl)
3886            set portname $portinfo(name)
3887        }
3888       
3889       
3890        # Calculate portdir, porturl, and portfile from initial porturl
3891        set portdir [file normalize [macports::getportdir $porturl]]
3892        set porturl "file://${portdir}";    # Rebuild url so it's fully qualified
3893        set portfile "${portdir}/Portfile"
3894       
3895        # Now execute the specific action
3896        if {[file readable $portfile]} {
3897            switch -- $action {
3898                cat {
3899                    # Copy the portfile to standard output
3900                    set f [open $portfile RDONLY]
3901                    while { ![eof $f] } {
3902                        puts -nonewline [read $f 4096]
3903                    }
3904                    close $f
3905                }
3906               
3907                edit {
3908                    # Edit the port's portfile with the user's editor
3909                   
3910                    # Restore our entire environment from start time.
3911                    # We need it to evaluate the editor, and the editor
3912                    # may want stuff from it as well, like TERM.
3913                    array unset env_save; array set env_save [array get env]
3914                    array unset env *
3915                    if {${macports::macosx_version} eq "10.5"} {
3916                        unsetenv *
3917                    }
3918                    array set env [array get boot_env]
3919                   
3920                    # Find an editor to edit the portfile
3921                    set editor ""
3922                    set editor_var "ports_${action}_editor"
3923                    if {[info exists local_options($editor_var)]} {
3924                        set editor [join $local_options($editor_var)]
3925                    } else {
3926                        foreach ed { MP_EDITOR VISUAL EDITOR } {
3927                            if {[info exists env($ed)]} {
3928                                set editor $env($ed)
3929                                break
3930                            }
3931                        }
3932                    }
3933                   
3934                    # Use a reasonable canned default if no editor specified or set in env
3935                    if { $editor eq "" } { set editor "/usr/bin/vi" }
3936                   
3937                    # Invoke the editor
3938                    if {[catch {exec -ignorestderr >@stdout <@stdin {*}$editor $portfile} result]} {
3939                        global errorInfo
3940                        ui_debug "$errorInfo"
3941                        break_softcontinue "unable to invoke editor $editor: $result" 1 status
3942                    }
3943                   
3944                    # Restore internal MacPorts environment
3945                    array unset env *
3946                    if {${macports::macosx_version} eq "10.5"} {
3947                        unsetenv *
3948                    }
3949                    array set env [array get env_save]
3950                }
3951
3952                dir {
3953                    # output the path to the port's directory
3954                    puts $portdir
3955                }
3956
3957                work {
3958                    # output the path to the port's work directory
3959                    set workpath [macports::getportworkpath_from_portdir $portdir $portname]
3960                    if {[file exists $workpath]} {
3961                        puts $workpath
3962                    }
3963                }
3964
3965                cd {
3966                    # Change to the port's directory, making it the default
3967                    # port for any future commands
3968                    set current_portdir $portdir
3969                }
3970
3971                url {
3972                    # output the url of the port's directory, suitable to feed back in later as a port descriptor
3973                    puts $porturl
3974                }
3975
3976                file {
3977                    # output the path to the port's portfile
3978                    puts $portfile
3979                }
3980
3981                logfile {
3982                    set logfile [file join [macports::getportlogpath $portdir $portname] "main.log"]
3983                    if {[file isfile $logfile]} {
3984                        puts $logfile
3985                    } else {
3986                        ui_error "Log file not found for port in $portdir"
3987                    }
3988                }
3989
3990                gohome {
3991                    set homepage ""
3992
3993                    # Get the homepage as read from PortIndex
3994                    if {[info exists portinfo(homepage)]} {
3995                        set homepage $portinfo(homepage)
3996                    }
3997
3998                    # If not available, get the homepage for the port by opening the Portfile
3999                    if {$homepage eq "" && ![catch {set ctx [mportopen $porturl]} result]} {
4000                        array set portinfo [mportinfo $ctx]
4001                        if {[info exists portinfo(homepage)]} {
4002                            set homepage $portinfo(homepage)
4003                        }
4004                        mportclose $ctx
4005                    }
4006
4007                    # Try to open a browser to the homepage for the given port
4008                    if { $homepage ne "" } {
4009                        if {[catch {system "${macports::autoconf::open_path} '$homepage'"} result]} {
4010                            global errorInfo
4011                            ui_debug "$errorInfo"
4012                            break_softcontinue "unable to invoke browser using ${macports::autoconf::open_path}: $result" 1 status
4013                        }
4014                    } else {
4015                        ui_error [format "No homepage for %s" $portname]
4016                    }
4017                }
4018            }
4019        } else {
4020            break_softcontinue "Could not read $portfile" 1 status
4021        }
4022    }
4023   
4024    return $status
4025}
4026
4027
4028proc action_sync { action portlist opts } {
4029    global global_options
4030
4031    set status 0
4032    if {[catch {mportsync [array get global_options]} result]} {
4033        global errorInfo
4034        ui_debug "$errorInfo"
4035        ui_msg "port sync failed: $result"
4036        set status 1
4037    }
4038   
4039    return $status
4040}
4041
4042
4043proc action_target { action portlist opts } {
4044    global global_variations
4045    set status 0
4046    if {[require_portlist portlist]} {
4047        return 1
4048    }
4049    if {($action eq "install" || $action eq "archive") && [prefix_unwritable] && ![macports::global_option_isset ports_dryrun]} {
4050        return 1
4051    }
4052    foreachport $portlist {
4053        array unset portinfo
4054        # If we have a url, use that, since it's most specific
4055        # otherwise try to map the portname to a url
4056        if {$porturl eq ""} {
4057            # Verify the portname, getting portinfo to map to a porturl
4058            if {[catch {set res [mportlookup $portname]} result]} {
4059                global errorInfo
4060                ui_debug "$errorInfo"
4061                break_softcontinue "lookup of portname $portname failed: $result" 1 status
4062            }
4063            if {[llength $res] < 2} {
4064                # don't error for ports that are installed but not in the tree
4065                if {[registry::entry_exists_for_name $portname]} {
4066                    ui_warn "Skipping $portname (not in the ports tree)"
4067                    continue
4068                } else {
4069                    break_softcontinue "Port $portname not found" 1 status
4070                }
4071            }
4072            array set portinfo [lindex $res 1]
4073            set porturl $portinfo(porturl)
4074        }
4075
4076        # use existing variants iff none were explicitly requested
4077        if {[array get requested_variations] eq "" && [array get variations] ne ""} {
4078            array unset requested_variations
4079            array set requested_variations [array get variations]
4080        }
4081
4082        # Add any global_variations to the variations
4083        # specified for the port
4084        foreach { variation value } [array get global_variations] {
4085            if { ![info exists requested_variations($variation)] } {
4086                set requested_variations($variation) $value
4087            }
4088        }
4089
4090        # If version was specified, save it as a version glob for use
4091        # in port actions (e.g. clean).
4092        if {[string length $portversion]} {
4093            set options(ports_version_glob) $portversion
4094        }
4095        # if installing, mark the port as explicitly requested
4096        if {$action eq "install"} {
4097            if {![info exists options(ports_install_unrequested)]} {
4098                set options(ports_requested) 1
4099            }
4100            # we actually activate as well
4101            set target activate
4102        } elseif {$action eq "archive"} {
4103            set target install
4104        } else {
4105            set target $action
4106        }
4107        if {![info exists options(subport)]} {
4108            if {[info exists portinfo(name)]} {
4109                set options(subport) $portinfo(name)
4110            } else {
4111                set options(subport) $portname
4112            }
4113        }
4114        if {[catch {set workername [mportopen $porturl [array get options] [array get requested_variations]]} result]} {
4115            global errorInfo
4116            ui_debug "$errorInfo"
4117            break_softcontinue "Unable to open port: $result" 1 status
4118        }
4119        if {[catch {set result [mportexec $workername $target]} result]} {
4120            global errorInfo
4121            mportclose $workername
4122            ui_debug "$errorInfo"
4123            break_softcontinue "Unable to execute port: $result" 1 status
4124        }
4125
4126        mportclose $workername
4127       
4128        # Process any error that wasn't thrown and handled already
4129        if {$result} {
4130            print_tickets_url
4131            break_softcontinue "Processing of port $portname failed" 1 status
4132        }
4133    }
4134   
4135    if {$status == 0 && $action eq "install" && ![macports::global_option_isset ports_dryrun]} {
4136        array set options $opts
4137        if {![info exists options(ports_nodeps)] && ![info exists options(ports_install_no-rev-upgrade)] && ${macports::revupgrade_autorun}} {
4138            set status [action_revupgrade $action $portlist $opts]
4139        }
4140    }
4141
4142    return $status
4143}
4144
4145
4146proc action_exit { action portlist opts } {
4147    # Return a semaphore telling the main loop to quit
4148    return -999
4149}
4150
4151
4152##########################################
4153# Command Parsing
4154##########################################
4155proc moreargs {} {
4156    global cmd_argn cmd_argc
4157    return [expr {$cmd_argn < $cmd_argc}]
4158}
4159
4160
4161proc lookahead {} {
4162    global cmd_argn cmd_argc cmd_argv
4163    if {$cmd_argn < $cmd_argc} {
4164        return [lindex $cmd_argv $cmd_argn]
4165    } else {
4166        return _EOF_
4167    }
4168}
4169
4170
4171proc advance {} {
4172    global cmd_argn
4173    incr cmd_argn
4174}
4175
4176
4177proc match s {
4178    if {[lookahead] == $s} {
4179        advance
4180        return 1
4181    }
4182    return 0
4183}
4184
4185# action_array specifies which action to run on the given command
4186# and if the action wants an expanded portlist.
4187# The value is a list of the form {action expand},
4188# where action is a string and expand a value:
4189#   0 none        Does not expect any text argument
4190#   1 strings     Expects some strings as text argument
4191#   2 ports       Wants an expanded list of ports as text argument
4192global action_array
4193
4194# Define global constants
4195const ACTION_ARGS_NONE 0
4196const ACTION_ARGS_STRINGS 1
4197const ACTION_ARGS_PORTS 2
4198
4199array set action_array [list \
4200    usage       [list action_usage          [ACTION_ARGS_STRINGS]] \
4201    help        [list action_help           [ACTION_ARGS_STRINGS]] \
4202    \
4203    echo        [list action_echo           [ACTION_ARGS_PORTS]] \
4204    \
4205    info        [list action_info           [ACTION_ARGS_PORTS]] \
4206    location    [list action_location       [ACTION_ARGS_PORTS]] \
4207    notes       [list action_notes          [ACTION_ARGS_PORTS]] \
4208    provides    [list action_provides       [ACTION_ARGS_STRINGS]] \
4209    log         [list action_log            [ACTION_ARGS_PORTS]] \
4210    \
4211    activate    [list action_activate       [ACTION_ARGS_PORTS]] \
4212    deactivate  [list action_deactivate     [ACTION_ARGS_PORTS]] \
4213    \
4214    select      [list action_select         [ACTION_ARGS_STRINGS]] \
4215    \
4216    sync        [list action_sync           [ACTION_ARGS_NONE]] \
4217    selfupdate  [list action_selfupdate     [ACTION_ARGS_NONE]] \
4218    \
4219    setrequested   [list action_setrequested  [ACTION_ARGS_PORTS]] \
4220    unsetrequested [list action_setrequested  [ACTION_ARGS_PORTS]] \
4221    setunrequested [list action_setrequested  [ACTION_ARGS_PORTS]] \
4222    \
4223    upgrade     [list action_upgrade        [ACTION_ARGS_PORTS]] \
4224    rev-upgrade [list action_revupgrade     [ACTION_ARGS_NONE]] \
4225    reclaim     [list action_reclaim        [ACTION_ARGS_NONE]] \
4226    diagnose    [list action_diagnose       [ACTION_ARGS_NONE]] \
4227    \
4228    version     [list action_version        [ACTION_ARGS_NONE]] \
4229    platform    [list action_platform       [ACTION_ARGS_NONE]] \
4230    \
4231    uninstall   [list action_uninstall      [ACTION_ARGS_PORTS]] \
4232    \
4233    installed   [list action_installed      [ACTION_ARGS_PORTS]] \
4234    outdated    [list action_outdated       [ACTION_ARGS_PORTS]] \
4235    contents    [list action_contents       [ACTION_ARGS_PORTS]] \
4236    space       [list action_space          [ACTION_ARGS_PORTS]] \
4237    dependents  [list action_dependents     [ACTION_ARGS_PORTS]] \
4238    rdependents [list action_dependents     [ACTION_ARGS_PORTS]] \
4239    deps        [list action_deps           [ACTION_ARGS_PORTS]] \
4240    rdeps       [list action_deps           [ACTION_ARGS_PORTS]] \
4241    variants    [list action_variants       [ACTION_ARGS_PORTS]] \
4242    \
4243    search      [list action_search         [ACTION_ARGS_STRINGS]] \
4244    list        [list action_list           [ACTION_ARGS_PORTS]] \
4245    \
4246    edit        [list action_portcmds       [ACTION_ARGS_PORTS]] \
4247    cat         [list action_portcmds       [ACTION_ARGS_PORTS]] \
4248    dir         [list action_portcmds       [ACTION_ARGS_PORTS]] \
4249    work        [list action_portcmds       [ACTION_ARGS_PORTS]] \
4250    cd          [list action_portcmds       [ACTION_ARGS_PORTS]] \
4251    url         [list action_portcmds       [ACTION_ARGS_PORTS]] \
4252    file        [list action_portcmds       [ACTION_ARGS_PORTS]] \
4253    logfile     [list action_portcmds       [ACTION_ARGS_PORTS]] \
4254    gohome      [list action_portcmds       [ACTION_ARGS_PORTS]] \
4255    \
4256    fetch       [list action_target         [ACTION_ARGS_PORTS]] \
4257    checksum    [list action_target         [ACTION_ARGS_PORTS]] \
4258    extract     [list action_target         [ACTION_ARGS_PORTS]] \
4259    patch       [list action_target         [ACTION_ARGS_PORTS]] \
4260    configure   [list action_target         [ACTION_ARGS_PORTS]] \
4261    build       [list action_target         [ACTION_ARGS_PORTS]] \
4262    destroot    [list action_target         [ACTION_ARGS_PORTS]] \
4263    install     [list action_target         [ACTION_ARGS_PORTS]] \
4264    clean       [list action_target         [ACTION_ARGS_PORTS]] \
4265    test        [list action_target         [ACTION_ARGS_PORTS]] \
4266    lint        [list action_target         [ACTION_ARGS_PORTS]] \
4267    livecheck   [list action_target         [ACTION_ARGS_PORTS]] \
4268    distcheck   [list action_target         [ACTION_ARGS_PORTS]] \
4269    mirror      [list action_target         [ACTION_ARGS_PORTS]] \
4270    load        [list action_target         [ACTION_ARGS_PORTS]] \
4271    unload      [list action_target         [ACTION_ARGS_PORTS]] \
4272    reload      [list action_target         [ACTION_ARGS_PORTS]] \
4273    distfiles   [list action_target         [ACTION_ARGS_PORTS]] \
4274    \
4275    archivefetch [list action_target         [ACTION_ARGS_PORTS]] \
4276    archive     [list action_target         [ACTION_ARGS_PORTS]] \
4277    unarchive   [list action_target         [ACTION_ARGS_PORTS]] \
4278    dmg         [list action_target         [ACTION_ARGS_PORTS]] \
4279    mdmg        [list action_target         [ACTION_ARGS_PORTS]] \
4280    mpkg        [list action_target         [ACTION_ARGS_PORTS]] \
4281    pkg         [list action_target         [ACTION_ARGS_PORTS]] \
4282    \
4283    quit        [list action_exit           [ACTION_ARGS_NONE]] \
4284    exit        [list action_exit           [ACTION_ARGS_NONE]] \
4285]
4286
4287# Expand "action".
4288# Returns an action proc, or a list of matching action procs, or the action passed in
4289proc find_action { action } {
4290    global action_array
4291   
4292    if { ! [info exists action_array($action)] } {
4293        set guess [guess_action $action]
4294        if { [info exists action_array($guess)] } {
4295            return $guess
4296        }
4297        return $guess
4298    }
4299   
4300    return $action
4301}
4302
4303# Expand action
4304# If there's more than one match, return the next possibility
4305proc find_action_proc { action } {
4306    global action_array
4307   
4308    set action_proc ""
4309    if { [info exists action_array($action)] } {
4310        set action_proc [lindex $action_array($action) 0]
4311    } else {
4312        set action [complete_action $action]
4313        if { [info exists action_array($action)] } {
4314            set action_proc [lindex $action_array($action) 0]
4315        }
4316    }
4317   
4318    return $action_proc
4319}
4320
4321proc get_action_proc { action } {
4322    global action_array
4323   
4324    set action_proc ""
4325    if { [info exists action_array($action)] } {
4326        set action_proc [lindex $action_array($action) 0]
4327    }
4328   
4329    return $action_proc
4330}
4331
4332# Returns whether an action expects text arguments at all,
4333# expects text arguments or wants an expanded list of ports
4334# Return values are constants:
4335#   [ACTION_ARGS_NONE]     Does not expect any text argument
4336#   [ACTION_ARGS_STRINGS]  Expects some strings as text argument
4337#   [ACTION_ARGS_PORTS]    Wants an expanded list of ports as text argument
4338proc action_needs_portlist { action } {
4339    global action_array
4340
4341    set ret 0
4342    if {[info exists action_array($action)]} {
4343        set ret [lindex $action_array($action) 1]
4344    }
4345
4346    return $ret
4347}
4348
4349# cmd_opts_array specifies which arguments the commands accept
4350# Commands not listed here do not accept any arguments
4351# Syntax if {option argn}
4352# Where option is the name of the option and argn specifies how many arguments
4353# this argument takes
4354global cmd_opts_array
4355array set cmd_opts_array {
4356    edit        {{editor 1}}
4357    info        {category categories conflicts depends_fetch depends_extract
4358                 depends_build depends_lib depends_run
4359                 depends description epoch fullname heading homepage index license
4360                 line long_description
4361                 maintainer maintainers name patchfiles platform platforms portdir
4362                 pretty replaced_by revision subports variant variants version}
4363    contents    {size {units 1}}
4364    deps        {index no-build}
4365    rdeps       {index no-build full}
4366    rdependents {full}
4367    search      {case-sensitive category categories depends_fetch
4368                 depends_extract depends_build depends_lib depends_run
4369                 depends description epoch exact glob homepage line
4370                 long_description maintainer maintainers name platform
4371                 platforms portdir regex revision variant variants version}
4372    selfupdate  {nosync}
4373    space       {{units 1} total}
4374    activate    {no-exec}
4375    deactivate  {no-exec}
4376    install     {no-rev-upgrade unrequested}
4377    uninstall   {follow-dependents follow-dependencies no-exec}
4378    variants    {index}
4379    clean       {all archive dist work logs}
4380    mirror      {new}
4381    lint        {nitpick}
4382    select      {list set show summary}
4383    log         {{phase 1} {level 1}}
4384    upgrade     {force enforce-variants no-replace no-rev-upgrade}
4385    rev-upgrade {id-loadcmd-check}
4386    diagnose    {quiet}
4387}
4388
4389##
4390# Checks whether the given option is valid
4391#
4392# @param action for which action
4393# @param option the prefix of the option to check
4394# @return list of pairs {name argc} for all matching options
4395proc cmd_option_matches {action option} {
4396    global cmd_opts_array
4397
4398    # This could be so easy with lsearch -index,
4399    # but that's only available as of Tcl 8.5
4400
4401    if {![info exists cmd_opts_array($action)]} {
4402        return {}
4403    }
4404
4405    set result {}
4406
4407    foreach item $cmd_opts_array($action) {
4408        if {[llength $item] == 1} {
4409            set name $item
4410            set argc 0
4411        } else {
4412            set name [lindex $item 0]
4413            set argc [lindex $item 1]
4414        }
4415
4416        if {$name == $option} {
4417            set result [list [list $name $argc]]
4418            break
4419        } elseif {[string first $option $name] == 0} {
4420            lappend result [list $name $argc]
4421        }
4422    }
4423
4424    return $result
4425}
4426
4427# Parse global options
4428#
4429# Note that this is called several times:
4430#   (1) Initially, to parse options that will be constant across all commands
4431#       (options that come prior to any command, frozen into global_options_base)
4432#   (2) Following each command (to parse options that will be unique to that command
4433#       (the global_options array is reset to global_options_base prior to each command)
4434#
4435proc parse_options { action ui_options_name global_options_name } {
4436    upvar $ui_options_name ui_options
4437    upvar $global_options_name global_options
4438    global cmdname cmd_opts_array
4439   
4440    while {[moreargs]} {
4441        set arg [lookahead]
4442       
4443        if {[string index $arg 0] ne "-"} {
4444            break
4445        } elseif {[string index $arg 1] eq "-"} {
4446            # Process long arguments
4447            switch -- $arg {
4448                -- { # This is the options terminator; do no further option processing
4449                    advance; break
4450                }
4451                default {
4452                    set key [string range $arg 2 end]
4453                    set kopts [cmd_option_matches $action $key]
4454                    if {[llength $kopts] == 0} {
4455                        return -code error "${action} does not accept --${key}"
4456                    } elseif {[llength $kopts] > 1} {
4457                        set errlst {}
4458                        foreach e $kopts {
4459                            lappend errlst "--[lindex $e 0]"
4460                        }
4461                        return -code error "\"port ${action} --${key}\" is ambiguous: \n  port ${action} [join $errlst "\n  port ${action} "]"
4462                    }
4463                    set key   [lindex $kopts 0 0]
4464                    set kargc [lindex $kopts 0 1]
4465                    if {$kargc == 0} {
4466                        set global_options(ports_${action}_${key}) yes
4467                    } else {
4468                        set args {}
4469                        while {[moreargs] && $kargc > 0} {
4470                            advance
4471                            lappend args [lookahead]
4472                            set kargc [expr {$kargc - 1}]
4473                        }
4474                        if {$kargc > 0} {
4475                            return -code error "--${key} expects [expr {$kargc + [llength $args]}] parameters!"
4476                        }
4477                        set global_options(ports_${action}_${key}) $args
4478                    }
4479                }
4480            }
4481        } else {
4482            # Process short arg(s)
4483            set opts [string range $arg 1 end]
4484            foreach c [split $opts {}] {
4485                switch -- $c {
4486                    v {
4487                        set ui_options(ports_verbose) yes
4488                    }
4489                    d {
4490                        set ui_options(ports_debug) yes
4491                        # debug implies verbose
4492                        set ui_options(ports_verbose) yes
4493                    }
4494                    q {
4495                        set ui_options(ports_quiet) yes
4496                        # quiet implies noninteractive
4497                        set ui_options(ports_noninteractive) yes
4498                    }
4499                    p {
4500                        # Ignore errors while processing within a command
4501                        set ui_options(ports_processall) yes
4502                    }
4503                    N { 
4504                        # Interactive mode is available or not
4505                        set ui_options(ports_noninteractive) yes
4506                    }
4507                    f {
4508                        set global_options(ports_force) yes
4509                    }
4510                    o {
4511                        set global_options(ports_ignore_different) yes
4512                    }
4513                    n {
4514                        set global_options(ports_nodeps) yes
4515                    }
4516                    u {
4517                        set global_options(port_uninstall_old) yes
4518                    }
4519                    R {
4520                        set global_options(ports_do_dependents) yes
4521                    }
4522                    s {
4523                        set global_options(ports_source_only) yes
4524                    }
4525                    b {
4526                        set global_options(ports_binary_only) yes
4527                    }
4528                    c {
4529                        set global_options(ports_autoclean) yes
4530                    }
4531                    k {
4532                        set global_options(ports_autoclean) no
4533                    }
4534                    t {
4535                        set global_options(ports_trace) yes
4536                    }
4537                    y {
4538                        set global_options(ports_dryrun) yes
4539                    }
4540                    F {
4541                        # Name a command file to process
4542                        advance
4543                        if {[moreargs]} {
4544                            lappend ui_options(ports_commandfiles) [lookahead]
4545                        }
4546                    }
4547                    D {
4548                        advance
4549                        if {[moreargs]} {
4550                            cd [lookahead]
4551                        }
4552                        break
4553                    }
4554                    default {
4555                        print_usage; exit 1
4556                    }
4557                }
4558            }
4559        }
4560
4561        advance
4562    }
4563}
4564
4565# acquire exclusive registry lock for actions that need it
4566# returns 1 if locked, 0 otherwise
4567proc lock_reg_if_needed {action} {
4568    switch -- $action {
4569        activate -
4570        deactivate -
4571        setrequested -
4572        unsetrequested -
4573        setunrequested -
4574        upgrade -
4575        uninstall -
4576        install {
4577            registry::exclusive_lock
4578            return 1
4579        }
4580    }
4581    return 0
4582}
4583
4584proc process_cmd { argv } {
4585    global cmd_argc cmd_argv cmd_argn \
4586           global_options global_options_base private_options ui_options \
4587           current_portdir
4588    set cmd_argv $argv
4589    set cmd_argc [llength $argv]
4590    set cmd_argn 0
4591
4592    set action_status 0
4593
4594    # Process an action if there is one
4595    while {($action_status == 0 || [macports::ui_isset ports_processall]) && [moreargs]} {
4596        set action [lookahead]
4597        advance
4598       
4599        # Handle command separator
4600        if { $action == ";" } {
4601            continue
4602        }
4603       
4604        # Handle a comment
4605        if { [string index $action 0] == "#" } {
4606            while { [moreargs] } { advance }
4607            break
4608        }
4609
4610        set locked [lock_reg_if_needed $action]
4611        # Always start out processing an action in current_portdir
4612        cd $current_portdir
4613       
4614        # Reset global_options from base before each action, as we munge it just below...
4615        array unset global_options
4616        array set global_options $global_options_base
4617       
4618        # Find an action to execute
4619        set actions [find_action $action]
4620        if {[llength $actions] == 1} {
4621            set action [lindex $actions 0]
4622            set action_proc [get_action_proc $action]
4623        } else {
4624            if {[llength $actions] > 1} {
4625                ui_error "\"port ${action}\" is ambiguous: \n  port [join $actions "\n  port "]"
4626            } else {
4627                ui_error "Unrecognized action \"port $action\""
4628            }
4629            set action_status 1
4630            break
4631        }
4632
4633        # Parse options that will be unique to this action
4634        # (to avoid abiguity with -variants and a default port, either -- must be
4635        # used to terminate option processing, or the pseudo-port current must be specified).
4636        if {[catch {parse_options $action ui_options global_options} result]} {
4637            global errorInfo
4638            ui_debug "$errorInfo"
4639            ui_error $result
4640            set action_status 1
4641            break
4642        }
4643
4644        # What kind of arguments does the command expect?
4645        set expand [action_needs_portlist $action]
4646
4647        # (Re-)initialize private_options(ports_no_args) to no, because it might still be yes
4648        # from the last command in batch mode. If we don't do this, port will fail to
4649        # distinguish arguments that expand to empty lists from no arguments at all:
4650        # > installed
4651        # > list outdated
4652        # will then behave like
4653        # > list
4654        # if outdated expands to the empty list. See #44091, which was filed about this.
4655        set private_options(ports_no_args) "no"
4656
4657        # Parse action arguments, setting a special flag if there were none
4658        # We otherwise can't tell the difference between arguments that evaluate
4659        # to the empty set, and the empty set itself.
4660        set portlist {}
4661        switch -- [lookahead] {
4662            ;       -
4663            _EOF_ {
4664                set private_options(ports_no_args) "yes"
4665            }
4666            default {
4667                if {[ACTION_ARGS_NONE] == $expand} {
4668                    ui_error "$action does not accept string arguments"
4669                    set action_status 1
4670                    break
4671                } elseif {[ACTION_ARGS_STRINGS] == $expand} {
4672                    while { [moreargs] && ![match ";"] } {
4673                        lappend portlist [lookahead]
4674                        advance
4675                    }
4676                } elseif {[ACTION_ARGS_PORTS] == $expand} {
4677                    # Parse port specifications into portlist
4678                    if {![portExpr portlist]} {
4679                        ui_error "Improper expression syntax while processing parameters"
4680                        set action_status 1
4681                        break
4682                    }
4683                }
4684            }
4685        }
4686       
4687        # execute the action
4688        set action_status [$action_proc $action $portlist [array get global_options]]
4689
4690        # unlock if needed
4691        if {$locked} {
4692            registry::exclusive_unlock
4693        }
4694
4695        # Print notifications of just-activated ports.
4696        portclient::notifications::display
4697
4698        # semaphore to exit
4699        if {$action_status == -999} break
4700    }
4701   
4702    return $action_status
4703}
4704
4705
4706proc complete_portname { text state } { 
4707    global complete_choices complete_position
4708   
4709    if {$state == 0} {
4710        set complete_position 0
4711        set complete_choices {}
4712
4713        # Build a list of ports with text as their prefix
4714        if {[catch {set res [mportsearch "${text}*" false glob]} result]} {
4715            global errorInfo
4716            ui_debug "$errorInfo"
4717            fatal "search for portname $pattern failed: $result"
4718        }
4719        foreach {name info} $res {
4720            lappend complete_choices $name
4721        }
4722    }
4723   
4724    set word [lindex $complete_choices $complete_position]
4725    incr complete_position
4726   
4727    return $word
4728}
4729
4730
4731# return text action beginning with $text
4732proc complete_action { text state } {   
4733    global action_array complete_choices complete_position
4734
4735    if {$state == 0} {
4736        set complete_position 0
4737        set complete_choices [array names action_array "[string tolower $text]*"]
4738    }
4739
4740    set word [lindex $complete_choices $complete_position]
4741    incr complete_position
4742
4743    return $word
4744}
4745
4746# return all actions beginning with $text
4747proc guess_action { text } {   
4748    global action_array
4749
4750    return [array names action_array "[string tolower $text]*"]
4751
4752    if { [llength $complete_choices ] == 1 } {
4753        return [lindex $complete_choices 0]
4754    }
4755
4756    return {}
4757}
4758
4759proc attempt_completion { text word start end } {
4760    # If the word starts with '~', or contains '.' or '/', then use the build-in
4761    # completion to complete the word
4762    if { [regexp {^~|[/.]} $word] } {
4763        return ""
4764    }
4765
4766    # Decide how to do completion based on where we are in the string
4767    set prefix [string range $text 0 [expr {$start - 1}]]
4768   
4769    # If only whitespace characters preceed us, or if the
4770    # previous non-whitespace character was a ;, then we're
4771    # an action (the first word of a command)
4772    if { [regexp {(^\s*$)|(;\s*$)} $prefix] } {
4773        return complete_action
4774    }
4775   
4776    # Otherwise, do completion on portname
4777    return complete_portname
4778}
4779
4780
4781proc get_next_cmdline { in out use_readline prompt linename } {
4782    upvar $linename line
4783   
4784    set line ""
4785    while { $line eq "" } {
4786
4787        if {$use_readline} {
4788            set len [readline read -attempted_completion attempt_completion line $prompt]
4789        } else {
4790            puts -nonewline $out $prompt
4791            flush $out
4792            set len [gets $in line]
4793        }
4794
4795        if { $len < 0 } {
4796            return -1
4797        }
4798       
4799        set line [string trim $line]
4800
4801        if { $use_readline && $line ne "" } {
4802            rl_history add $line
4803        }
4804    }
4805   
4806    return [llength $line]
4807}
4808
4809
4810proc process_command_file { in } {
4811    global current_portdir
4812
4813    # Initialize readline
4814    set isstdin [string match $in "stdin"]
4815    set name "port"
4816    set use_readline [expr {$isstdin && [readline init $name]}]
4817    set history_file [file normalize "${macports::macports_user_dir}/history"]
4818
4819    # Read readline history
4820    if {$use_readline && [file isdirectory $macports::macports_user_dir]} {
4821        rl_history read $history_file
4822        rl_history stifle 100
4823    }
4824
4825    # Be noisy, if appropriate
4826    set noisy [expr $isstdin && ![macports::ui_isset ports_quiet]]
4827    if { $noisy } {
4828        puts "MacPorts [macports::version]"
4829        puts "Entering interactive mode... (\"help\" for help, \"quit\" to quit)"
4830    }
4831
4832    # Main command loop
4833    set exit_status 0
4834    while { $exit_status == 0 || $isstdin || [macports::ui_isset ports_processall] } {
4835
4836        # Calculate our prompt
4837        if { $noisy } {
4838            set shortdir [file join {*}[lrange [file split $current_portdir] end-1 end]]
4839            set prompt "\[$shortdir\] > "
4840        } else {
4841            set prompt ""
4842        }
4843
4844        # Get a command line
4845        if { [get_next_cmdline $in stdout $use_readline $prompt line] <= 0  } {
4846            puts ""
4847            break
4848        }
4849
4850        # Process the command
4851        set exit_status [process_cmd $line]
4852       
4853        # Check for semaphore to exit
4854        if {$exit_status == -999} {
4855            set exit_status 0
4856            break
4857        }
4858    }
4859
4860    # Create macports user directory if it does not exist yet
4861    if {$use_readline && ![file isdirectory $macports::macports_user_dir]} {
4862        file mkdir $macports::macports_user_dir
4863    }
4864    # Save readine history
4865    if {$use_readline && [file isdirectory $macports::macports_user_dir]} {
4866        rl_history write $history_file
4867    }
4868
4869    # Say goodbye
4870    if { $noisy } {
4871        puts "Goodbye"
4872    }
4873
4874    return $exit_status
4875}
4876
4877
4878proc process_command_files { filelist } {
4879    set exit_status 0
4880
4881    # For each file in the command list, process commands
4882    # in the file
4883    foreach file $filelist {
4884        if {$file eq "-"} {
4885            set in stdin
4886        } else {
4887            if {[catch {set in [open $file]} result]} {
4888                fatal "Failed to open command file; $result"
4889            }
4890        }
4891
4892        set exit_status [process_command_file $in]
4893
4894        if {$in ne "stdin"} {
4895            close $in
4896        }
4897
4898        # Exit on first failure unless -p was given
4899        if {$exit_status != 0 && ![macports::ui_isset ports_processall]} {
4900            return $exit_status
4901        }
4902    }
4903
4904    return $exit_status
4905}
4906
4907namespace eval portclient::progress {
4908    ##
4909    # Maximum width of the progress bar or indicator when displaying it.
4910    variable maxWidth 50
4911
4912    ##
4913    # The start time of the last progress callback as returned by [clock time].
4914    # Since only one progress indicator is active at a time, this variable is
4915    # shared between the different variants of progress functions.
4916    variable startTime
4917
4918    ##
4919    # Delay in milliseconds after the start of the operation before deciding
4920    # that showing a progress bar makes sense.
4921    variable showTimeThreshold 500
4922
4923    ##
4924    # Percentage value between 0 and 1 that must not have been reached yet when
4925    # $showTimeThreshold has passed for a progress bar to be shown. If the
4926    # operation has proceeded above e.g. 75% after 500ms we won't bother
4927    # displaying a progress indicator anymore -- the operation will be finished
4928    # in well below a second anyway.
4929    variable showPercentageThreshold 0.75
4930
4931    ##
4932    # Boolean indication whether the progress indicator should be shown or is
4933    # still hidden because the current operation didn't need enough time for
4934    # a progress indicator to make sense, yet.
4935    variable show no
4936
4937    ##
4938    # Initialize the progress bar display delay; call this from the start
4939    # action of the progress functions.
4940    proc initDelay {} {
4941        variable show
4942        variable startTime
4943
4944        set startTime [clock milliseconds]
4945        set show no
4946    }
4947
4948    ##
4949    # Determine whether a progress bar should be shown for the current
4950    # operation in its current state. You must have called initDelay for the
4951    # current operation before calling this method.
4952    #
4953    # @param cur
4954    #        Current progress in abstract units.
4955    # @param total
4956    #        Total number of abstract units to be processed, if known. Pass
4957    #        0 if unknown.
4958    # @return
4959    #        "yes", if the progress indicator should be shown, "no" otherwise.
4960    proc showProgress {cur total} {
4961        variable show
4962        variable startTime
4963        variable showTimeThreshold
4964        variable showPercentageThreshold
4965
4966        if {$show eq "yes"} {
4967            return yes
4968        } else {
4969            if {[expr {[clock milliseconds] - $startTime}] > $showTimeThreshold &&
4970                ($total == 0 || [expr {double($cur) / double($total)}] < $showPercentageThreshold)} {
4971                set show yes
4972            }
4973            return $show
4974        }
4975    }
4976
4977    ##
4978    # Progress callback for generic operations executed by macports 1.0.
4979    #
4980    # @param action
4981    #        One of "start", "update", "intermission" or "finish", where start
4982    #        will be called before any number of update calls, interrupted by
4983    #        any number of intermission calls (called because other output is
4984    #        being produced), followed by one call to finish.
4985    # @param args
4986    #        A list of variadic args that differ for each action. For "start",
4987    #        "intermission" and "finish", the args are empty and unused. For
4988    #        "update", args contains $cur and $total, where $cur is the current
4989    #        number of units processed and $total is the total number of units
4990    #        to be processed. If the total is not known, it is 0.
4991    proc generic {action args} {
4992        global env
4993        variable maxWidth
4994
4995        switch -nocase -- $action {
4996            start {
4997                initDelay
4998            }
4999            update {
5000                # the for loop is a simple hack because Tcl 8.4 doesn't have
5001                # lassign
5002                foreach {now total} $args {
5003                    if {[showProgress $now $total] eq "yes"} {
5004                        set barPrefix "      "
5005                        set barPrefixLen [string length $barPrefix]
5006                        if {$total != 0} {
5007                            progressbar $now $total [expr {min($maxWidth, $env(COLUMNS) - $barPrefixLen)}] $barPrefix
5008                        } else {
5009                            unprogressbar [expr {min($maxWidth, $env(COLUMNS) - $barPrefixLen)}] $barPrefix
5010                        }
5011                    }
5012                }
5013            }
5014            intermission -
5015            finish {
5016                # erase to start of line
5017                ::term::ansi::send::esol
5018                # return cursor to start of line
5019                puts -nonewline "\r"
5020                flush stdout
5021            }
5022        }
5023
5024        return 0
5025    }
5026
5027    ##
5028    # Progress callback for downloads executed by macports 1.0.
5029    #
5030    # This is essentially a cURL progress callback.
5031    #
5032    # @param action
5033    #        One of "start", "update" or "finish", where start will be called
5034    #        before any number of update calls, followed by one call to finish.
5035    # @param args
5036    #        A list of variadic args that differ for each action. For "start",
5037    #        contains a single argument "ul" or "dl" indicating whether this is
5038    #        an up- or download. For "update", contains the arguments
5039    #        ("ul"|"dl") $total $now $speed where ul/dl are as for start, and
5040    #        total, now and speed are doubles indicating the total transfer
5041    #        size, currently transferred amount and average speed per second in
5042    #        bytes. Unused for "finish".
5043    proc download {action args} {
5044        global env
5045        variable maxWidth
5046
5047        switch -nocase -- $action {
5048            start {
5049                initDelay
5050            }
5051            update {
5052                # the for loop is a simple hack because Tcl 8.4 doesn't have
5053                # lassign
5054                foreach {type total now speed} $args {
5055                    if {[showProgress $now $total] eq "yes"} {
5056                        set barPrefix "      "
5057                        set barPrefixLen [string length $barPrefix]
5058                        if {$total != 0} {
5059                            set barSuffix [format "        speed: %-13s" "[bytesize $speed {} "%.1f"]/s"]
5060                            set barSuffixLen [string length $barSuffix]
5061
5062                            set barLen [expr {min($maxWidth, $env(COLUMNS) - $barPrefixLen - $barSuffixLen)}]
5063                            progressbar $now $total $barLen $barPrefix $barSuffix
5064                        } else {
5065                            set barSuffix [format " %-10s     speed: %-13s" [bytesize $now {} "%6.1f"] "[bytesize $speed {} "%.1f"]/s"]
5066                            set barSuffixLen [string length $barSuffix]
5067
5068                            set barLen [expr {min($maxWidth, $env(COLUMNS) - $barPrefixLen - $barSuffixLen)}]
5069                            unprogressbar $barLen $barPrefix $barSuffix
5070                        }
5071                    }
5072                }
5073            }
5074            finish {
5075                # erase to start of line
5076                ::term::ansi::send::esol
5077                # return cursor to start of line
5078                puts -nonewline "\r"
5079                flush stdout
5080            }
5081        }
5082
5083        return 0
5084    }
5085
5086    ##
5087    # Draw a progress bar using unicode block drawing characters
5088    #
5089    # @param current
5090    #        The current progress value.
5091    # @param total
5092    #        The progress value representing 100%.
5093    # @param width
5094    #        The width in characters of the progress bar. This includes percentage
5095    #        output, which takes up 8 characters.
5096    # @param prefix
5097    #        Prefix to be printed in front of the progress bar.
5098    # @param suffix
5099    #        Suffix to be printed after the progress bar.
5100    proc progressbar {current total width {prefix ""} {suffix ""}} {
5101        # Subtract the width of the percentage output, also subtract the two
5102        # characters [ and ] bounding the progress bar.
5103        set percentageWidth 8
5104        set barWidth      [expr {entier($width) - $percentageWidth - 2}]
5105
5106        # Map the range (0, $total) to (0, 4 * $width) where $width is the maximum
5107        # numebr of characters to be printed for the progress bar. Multiply the
5108        # upper bound with 8 because we have 8 sub-states per character.
5109        set barProgress   [expr {entier(round(($current * $barWidth * 8) / $total))}]
5110
5111        set barInteger    [expr {$barProgress / 8}]
5112        #set barRemainder  [expr {$barProgress % 8}]
5113
5114        # Finally, also provide a percentage value to print behind the progress bar
5115        set percentage [expr {double($current) * 100 / double($total)}]
5116
5117        # clear the current line, enable reverse video
5118        set progressbar "\033\[7m"
5119        for {set i 0} {$i < $barInteger} {incr i} {
5120            # U+2588 FULL BLOCK doesn't match the other blocks in some fonts :/
5121            # Two half blocks work better in some fonts, but not in others (because
5122            # they leave ugly spaces). So, one or the other choice isn't better or
5123            # worse and even just using full blocks looks ugly in a few fonts.
5124
5125            # Use pure ASCII until somebody fixes most of the default terminal fonts :/
5126            append progressbar " "
5127        }
5128        # back to normal output
5129        append progressbar "\033\[0m"
5130
5131        #switch $barRemainder {
5132        #    0 {
5133        #        if {$barInteger < $barWidth} {
5134        #            append progressbar " "
5135        #        }
5136        #    }
5137        #    1 {
5138        #        # U+258F LEFT ONE EIGHTH BLOCK
5139        #        append progressbar "\u258f"
5140        #    }
5141        #    2 {
5142        #        # U+258E LEFT ONE QUARTER BLOCK
5143        #        append progressbar "\u258e"
5144        #    }
5145        #    3 {
5146        #        # U+258D LEFT THREE EIGHTHS BLOCK
5147        #        append progressbar "\u258d"
5148        #    }
5149        #    3 {
5150        #        # U+258D LEFT THREE EIGHTHS BLOCK
5151        #        append progressbar "\u258d"
5152        #    }
5153        #    4 {
5154        #        # U+258C LEFT HALF BLOCK
5155        #        append progressbar "\u258c"
5156        #    }
5157        #    5 {
5158        #        # U+258B LEFT FIVE EIGHTHS BLOCK
5159        #        append progressbar "\u258b"
5160        #    }
5161        #    6 {
5162        #        # U+258A LEFT THREE QUARTERS BLOCK
5163        #        append progressbar "\u258a"
5164        #    }
5165        #    7 {
5166        #        # U+2589 LEFT SEVEN EIGHTHS BLOCK
5167        #        append progressbar "\u2589"
5168        #    }
5169        #}
5170
5171        # Fill the progress bar with spaces
5172        for {set i $barInteger} {$i < $barWidth} {incr i} {
5173            append progressbar " "
5174        }
5175
5176        # Format the percentage using the space that has been reserved for it
5177        set percentagesuffix [format " %[expr {$percentageWidth - 3}].1f %%" $percentage]
5178
5179        puts -nonewline "\r${prefix}\[${progressbar}\]${percentagesuffix}${suffix}"
5180        flush stdout
5181    }
5182
5183
5184    ##
5185    # Internal state of the progress indicator; unless you're hacking the
5186    # unprogressbar code you should never touch this.
5187    variable unprogressState 0
5188
5189    ##
5190    # Draw a progress indicator
5191    #
5192    # @param width
5193    #        The width in characters of the progress indicator.
5194    # @param prefix
5195    #        Prefix to be printed in front of the progress indicator.
5196    # @param suffix
5197    #        Suffix to be printed after the progress indicator.
5198    proc unprogressbar {width {prefix ""} {suffix ""}} {
5199        variable unprogressState
5200
5201        # Subtract the two characters [ and ] bounding the progress indicator
5202        # from the width.
5203        set barWidth [expr {int($width) - 2}]
5204
5205        # Number of states of the progress bar, or rather: the number of
5206        # characters before the sequence repeats.
5207        set numStates 4
5208
5209        set unprogressState [expr {($unprogressState + 1) % $numStates}]
5210
5211        set progressbar ""
5212        for {set i 0} {$i < $barWidth} {incr i} {
5213            if {[expr {$i % $numStates}] == $unprogressState} {
5214                # U+2022 BULLET
5215                append progressbar "\u2022"
5216            } else {
5217                append progressbar " "
5218            }
5219        }
5220
5221        puts -nonewline "\r${prefix}\[${progressbar}\]${suffix}"
5222        flush stdout
5223    }
5224}
5225
5226namespace eval portclient::notifications {
5227    ##
5228    # Ports whose notifications to display; these were either installed
5229    # or requested to be installed.
5230    variable notificationsToPrint
5231    array set notificationsToPrint {}
5232
5233    ##
5234    # Add a port to the list for printing notifications.
5235    #
5236    # @param name
5237    #        The name of the port.
5238    # @param note
5239    #        A list of notes to be stored for the given port.
5240    proc append {name notes} {
5241        variable notificationsToPrint
5242
5243        set notificationsToPrint($name) $notes
5244    }
5245
5246    ##
5247    # Print port notifications.
5248    #
5249    proc display {} {
5250        global env
5251        variable notificationsToPrint
5252
5253        # Display notes at the end of the activation phase.
5254        if {[array size notificationsToPrint] > 0} {
5255            ui_notice "--->  Some of the ports you installed have notes:"
5256            foreach name [lsort [array names notificationsToPrint]] {
5257                set notes $notificationsToPrint($name)
5258                ui_notice "  $name has the following notes:"
5259
5260                # If env(COLUMNS) exists, limit each line's width to this width.
5261                if {[info exists env(COLUMNS)]} {
5262                    set maxlen $env(COLUMNS)
5263
5264                    foreach note $notes {
5265                        foreach line [split $note "\n"] {
5266                            set joiner ""
5267                            set lines ""
5268                            set newline "    "
5269
5270                            foreach word [split $line " "] {
5271                                if {[string length $newline] + [string length $word] >= $maxlen} {
5272                                    lappend lines $newline
5273                                    set newline "    "
5274                                    set joiner ""
5275                                }
5276                                ::append newline $joiner $word
5277                                set joiner " "
5278                            }
5279                            if {$newline ne {}} {
5280                                lappend lines $newline
5281                            }
5282                            ui_notice [join $lines "\n"]
5283                        }
5284                    }
5285                } else {
5286                    foreach note $notes {
5287                        ui_notice $note
5288                    }
5289                }
5290            }
5291        }
5292    }
5293}
5294
5295# Create namespace for questions
5296namespace eval portclient::questions {
5297       
5298        package require Tclx
5299        ##
5300        # Function that handles printing of a timeout.
5301        #
5302        # @param time
5303        #        The amount of time for which a timeout is to occur.
5304        # @param def
5305        #        The default action to be taken in the occurence of a timeout.
5306        proc ui_timeout {def timeout} {
5307                fconfigure stdin -blocking 0
5308
5309                signal error {TERM INT}
5310                while {$timeout >= 0} {
5311                        if {[catch {set inp [read stdin]} err]} {
5312                                return -code error "Ctrl-C"
5313                        }
5314                        if {$inp eq "\n"} {
5315                                return $def
5316                        }
5317                        puts -nonewline "\r"
5318                        puts -nonewline [format "Continuing in %02d s. Press Ctrl-C to exit: " $timeout]
5319                        flush stdout
5320                        after 1000
5321                        incr timeout -1
5322                }
5323                puts ""
5324                fconfigure stdin -blocking 1
5325                signal -restart error {TERM INT}
5326                return $def
5327        }
5328       
5329        ##
5330        # Main function that displays numbered choices for a multiple choice question.
5331        #
5332        # @param msg
5333        #        The question specific message that is to be printed before asking the question.
5334        # @param ???name???
5335        #        May be a qid will be of better use instead as the client does not do anything port specific.
5336        # @param ports
5337        #        The list of ports for which the question is being asked.
5338        proc ui_choice {msg name ports} {
5339                # Print the main message
5340                puts $msg
5341               
5342                # Print portname or port list suitably
5343                set i 1
5344                foreach port $ports {
5345                        puts -nonewline " $i) "
5346                        puts [string map {@ " @" ( " ("} $port]
5347                        incr i
5348                }
5349        }
5350       
5351        ##
5352        # Displays a question with 'yes' and 'no' as options.
5353        # Waits for user input indefinitely unless a timeout is specified.
5354        # Shows the list of port passed to it without any numbers.
5355        #
5356        # @param msg
5357        #        The question specific message that is to be printed before asking the question.
5358        # @param ???name???
5359        #        May be a qid will be of better use instead as the client does not do anything port specific.
5360        # @param ports
5361        #        The port/list of ports for which the question is being asked.
5362        # @param def
5363        #        The default answer to the question.
5364        # @param time
5365        #                The amount of time for which a timeout is to occur.
5366        proc ui_ask_yesno {msg name ports def {timeout 0}} {
5367                # Set number default to the given letter default
5368                if {$def == {y}} {
5369                        set default 0
5370                } else {
5371                        set default 1
5372                }
5373               
5374                puts -nonewline $msg
5375                set leftmargin " "
5376               
5377                # Print portname or port list suitably
5378                if {[llength $ports] == 1} {
5379                        puts -nonewline " "
5380                        puts [string map {@ " @"} $ports]
5381                } else {
5382                        puts ""
5383                        foreach port $ports {
5384                                puts -nonewline $leftmargin 
5385                                puts [string map {@ " @"} $port]
5386                        }
5387                }
5388               
5389                # Check if timeout is set or not
5390                if {$timeout > 0} {
5391                        # Run ui_timeout and skip the rest of the stuff here
5392                        return [ui_timeout $default $timeout] 
5393                }
5394                               
5395                # Check for the default and print accordingly
5396                if {$def == {y}} {
5397                        puts -nonewline "Continue? \[Y/n\]: "
5398                        flush stdout
5399                } else {
5400                        puts -nonewline "Continue? \[y/N\]: "
5401                        flush stdout
5402                }
5403               
5404                # User input (probably requires some input error checking code)
5405                while 1 {
5406                        signal error {TERM INT}
5407                        if {[catch {set input [gets stdin]} err]} {
5408                                return -code error "Ctrl-C"
5409                        }
5410                        signal -restart error {TERM INT}
5411                        if {$input in {y Y}} {
5412                                return 0
5413                        } elseif {$input in {n N}} {
5414                                return 1
5415                        } elseif {$input == ""} {
5416                                return $default
5417                        } else {
5418                                puts "Please enter either 'y' or 'n'."
5419                        }
5420                }
5421        }
5422       
5423        ##
5424        # Displays a question with a list of numbered choices and asks the user to enter a number to specify their choice.
5425        # Waits for user input indefinitely.
5426        #
5427        # @param msg
5428        #        The question specific message that is to be printed before asking the question.
5429        # @param ???name???
5430        #        May be a qid will be of better use instead as the client does not do anything port specific.
5431        # @param ports
5432        #        The port/list of ports for which the question is being asked.
5433        proc ui_ask_singlechoice {msg name ports} {
5434                ui_choice $msg $name $ports
5435                               
5436                # User Input (single input restriction)
5437                while 1 {
5438                        puts -nonewline "Enter a number to select an option: "
5439                        flush stdout
5440                        signal error {TERM INT}
5441                        if {[catch {set input [gets stdin]} err]} {
5442                                return -code error "Ctrl-C"
5443                        }
5444                        signal -restart error {TERM INT}
5445                        if {($input <= [llength $ports] && [string is integer -strict $input])} {
5446                                return $input
5447                        } else {
5448                                puts "Please enter an index from the above list."
5449                        }
5450                }
5451        }
5452       
5453        ##
5454        # 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.
5455        # Waits for user input indefinitely.
5456        #
5457        # @param msg
5458        #        The question specific message that is to be printed before asking the question.
5459        # @param ???name???
5460        #        May be a qid will be of better use instead as the client does not do anything port specific.
5461        # @param ports
5462        #        The list of ports for which the question is being asked.
5463        proc ui_ask_multichoice {msg name ports} {
5464               
5465                ui_choice $msg $name $ports
5466                               
5467                # User Input (with Multiple input parsing)
5468                while 1 {
5469                        puts -nonewline "Enter the numbers to select the options: "
5470                        flush stdout
5471                        signal error {TERM INT}
5472                        if {[catch {set input [gets stdin]} err]} {
5473                                return -code error "Ctrl-C"
5474                        }
5475                        signal -restart error {TERM INT}
5476                        set count 0
5477                        # check if input is non-empty and otherwise fine
5478                        if {$input == ""} {
5479                                continue
5480                        }
5481                        foreach num $input {
5482                                if {($num <= [llength $ports] && [string is integer -strict $num])} {
5483                                        incr count
5484                                } else {
5485                                        puts "Please enter numbers separated by a space which are indices from the above list."
5486                                        break
5487                                }
5488                        }
5489                        if {$count == [llength $input]} {
5490                                return $input
5491                        }
5492                }
5493        }
5494}
5495
5496##########################################
5497# Main
5498##########################################
5499
5500# Global arrays passed to the macports1.0 layer
5501array set ui_options        {}
5502array set global_options    {}
5503array set global_variations {}
5504
5505# Global options private to this script
5506array set private_options {}
5507
5508# Make sure we get the size of the terminal
5509# We do this here to save it in the boot_env, in case we determined it manually
5510term_init_size
5511
5512global env boot_env argv0 cmdname argc argv cmd_argc cmd_argv cmd_argn \
5513       current_portdir global_options_base exit_status
5514
5515# Save off a copy of the environment before mportinit monkeys with it
5516array set boot_env [array get env]
5517
5518set cmdname [file tail $argv0]
5519
5520# Setp cmd_argv to match argv
5521set cmd_argv $argv
5522set cmd_argc $argc
5523set cmd_argn 0
5524
5525# make sure we're using a sane umask
5526umask 022
5527
5528# If we've been invoked as portf, then the first argument is assumed
5529# to be the name of a command file (i.e., there is an implicit -F
5530# before any arguments).
5531if {[moreargs] && $cmdname eq "portf"} {
5532    lappend ui_options(ports_commandfiles) [lookahead]
5533    advance
5534}
5535
5536# Parse global options that will affect all subsequent commands
5537if {[catch {parse_options "global" ui_options global_options} result]} {
5538    puts "Error: $result"
5539    print_usage
5540    exit 1
5541}
5542
5543if {[isatty stdout]
5544    && $portclient::progress::hasTermAnsiSend eq "yes"
5545    && (![info exists ui_options(ports_quiet)] || $ui_options(ports_quiet) ne "yes")} {
5546    set ui_options(progress_download) portclient::progress::download
5547    set ui_options(progress_generic)  portclient::progress::generic
5548}
5549
5550if {[isatty stdin]
5551        && [isatty stdout]
5552        && (![info exists ui_options(ports_quiet)] || $ui_options(ports_quiet) ne "yes")
5553        && (![info exists ui_options(ports_noninteractive)] || $ui_options(ports_noninteractive) ne "yes")} {
5554        set ui_options(questions_yesno) portclient::questions::ui_ask_yesno
5555        set ui_options(questions_singlechoice) portclient::questions::ui_ask_singlechoice
5556        set ui_options(questions_multichoice) portclient::questions::ui_ask_multichoice
5557}
5558
5559set ui_options(notifications_append) portclient::notifications::append
5560
5561# Get arguments remaining after option processing
5562set remaining_args [lrange $cmd_argv $cmd_argn end]
5563
5564# If we have no arguments remaining after option processing then force
5565# interactive mode
5566if { [llength $remaining_args] == 0 && ![info exists ui_options(ports_commandfiles)] } {
5567    lappend ui_options(ports_commandfiles) -
5568} elseif {[lookahead] eq "selfupdate" || [lookahead] eq "sync"} {
5569    # tell mportinit not to tell the user they should selfupdate
5570    set ui_options(ports_no_old_index_warning) 1
5571}
5572
5573# Initialize mport
5574# This must be done following parse of global options, as some options are
5575# evaluated by mportinit.
5576if {[catch {mportinit ui_options global_options global_variations} result]} {
5577    global errorInfo
5578    puts "$errorInfo"
5579    fatal "Failed to initialize MacPorts, $result"
5580}
5581
5582# Set up some global state for our code
5583set current_portdir [pwd]
5584
5585# Freeze global_options into global_options_base; global_options
5586# will be reset to global_options_base prior to processing each command.
5587set global_options_base [array get global_options]
5588
5589# First process any remaining args as action(s)
5590set exit_status 0
5591if { [llength $remaining_args] > 0 } {
5592
5593    # If there are remaining arguments, process those as a command
5594    set exit_status [process_cmd $remaining_args]
5595}
5596
5597# Process any prescribed command files, including standard input
5598if { ($exit_status == 0 || [macports::ui_isset ports_processall]) && [info exists ui_options(ports_commandfiles)] } {
5599    set exit_status [process_command_files $ui_options(ports_commandfiles)]
5600}
5601if {$exit_status == -999} {
5602    set exit_status 0
5603}
5604
5605# shut down macports1.0
5606mportshutdown
5607
5608# Return with exit_status
5609exit $exit_status
Note: See TracBrowser for help on using the repository browser.