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

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

Show date in verbose output of 'port installed'

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