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

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

combine multiple adjacent calls to global

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