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

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

port: use switch -matchvar from Tcl 8.5

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