source: branches/gsoc09-logging/base/src/port/port.tcl @ 52218

Last change on this file since 52218 was 52218, checked in by enl@…, 11 years ago

Merge from trunk

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 121.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 52218 2009-06-12 08:57:53Z enl@macports.org $
7#
8# Copyright (c) 2002-2007 The MacPorts Project.
9# Copyright (c) 2004 Robert Shaw <rshaw@opendarwin.org>
10# Copyright (c) 2002 Apple Computer, 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 Computer, 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
37catch {source \
38    [file join "@TCL_PACKAGE_DIR@" macports1.0 macports_fastload.tcl]}
39package require macports
40package require Pextlib 1.0
41
42
43# Standard procedures
44proc print_usage {{verbose 1}} {
45    global cmdname
46    set syntax {
47        [-bcdfknopqRstuvxy] [-D portdir] [-F cmdfile] action [privopts] [actionflags]
48        [[portname|pseudo-portname|port-url] [@version] [+-variant]... [option=value]...]...
49    }
50
51    if {$verbose} {
52        puts stderr "Usage: $cmdname$syntax"
53        puts stderr "\"$cmdname help\" or \"man 1 port\" for more information."
54    } else {
55        puts stderr "$cmdname$syntax"
56    }
57}
58
59proc print_help {args} {
60    global action_array
61
62    print_usage 0
63
64    # Generate and format the command list from the action_array
65    set cmds ""
66    set lineLen 0
67    foreach cmd [lsort [array names action_array]] {
68        if {$lineLen > 65} {
69            set cmds "$cmds,\n"
70            set lineLen 0
71        }
72        if {$lineLen == 0} {
73            set new "$cmd"
74        } else {
75            set new ", $cmd"
76        }
77        incr lineLen [string length $new]
78        set cmds "$cmds$new"
79    }
80
81    set cmdText [string range "
82Supported commands
83------------------
84$cmds
85" 1 end-1]
86
87    set text {
88Pseudo-portnames
89----------------
90Pseudo-portnames are words that may be used in place of a portname, and
91which expand to some set of ports. The common pseudo-portnames are:
92all, current, active, inactive, installed, uninstalled, outdated and obsolete.
93These pseudo-portnames expand to the set of ports named.
94
95Additional pseudo-portnames start with...
96variants:, variant:, description:, depends:, depends_lib:, depends_run:,
97depends_build:, depends_fetch:, depends_extract:, portdir:, homepage:, epoch:,
98platforms:, platform:, name:, long_description:, maintainers:, maintainer:,
99categories:, category:, version:, and revision:.
100These each select a set of ports based on a regex search of metadata
101about the ports. In all such cases, a standard regex pattern following
102the colon will be used to select the set of ports to which the
103pseudo-portname expands.
104
105Portnames that contain standard glob characters will be expanded to the
106set of ports matching the glob pattern.
107   
108Port expressions
109----------------
110Portnames, port glob patterns, and pseudo-portnames may be logically
111combined using expressions consisting of and, or, not, !, (, and ).
112   
113For more information
114--------------------
115See man pages: port(1), macports.conf(5), portfile(7), portgroup(7),
116porthier(7), portstyle(7). Also, see http://www.macports.org.
117    }
118
119    puts "$cmdText $text"
120}
121
122
123# Produce error message and exit
124proc fatal s {
125    global argv0
126    ui_error "$argv0: $s"
127    exit 1
128}
129
130
131# Produce an error message, and exit, unless
132# we're handling errors in a soft fashion, in which
133# case we continue
134proc fatal_softcontinue s {
135    if {[macports::global_option_isset ports_force]} {
136        ui_error $s
137        return -code continue
138    } else {
139        fatal $s
140    }
141}
142
143
144# Produce an error message, and break, unless
145# we're handling errors in a soft fashion, in which
146# case we continue
147proc break_softcontinue { msg status name_status } {
148    upvar $name_status status_var
149    ui_error $msg
150    if {[macports::ui_isset ports_processall]} {
151        set status_var 0
152        return -code continue
153    } else {
154        set status_var $status
155        return -code break
156    }
157}
158
159# Form a composite version as is sometimes used for registry functions
160proc composite_version {version variations {emptyVersionOkay 0}} {
161    # Form a composite version out of the version and variations
162   
163    # Select the variations into positive and negative
164    set pos {}
165    set neg {}
166    foreach { key val } $variations {
167        if {$val == "+"} {
168            lappend pos $key
169        } elseif {$val == "-"} {
170            lappend neg $key
171        }
172    }
173
174    # If there is no version, we have nothing to do
175    set composite_version ""
176    if {$version != "" || $emptyVersionOkay} {
177        set pos_str ""
178        set neg_str ""
179
180        if {[llength $pos]} {
181            set pos_str "+[join [lsort -ascii $pos] "+"]"
182        }
183        if {[llength $neg]} {
184            set neg_str "-[join [lsort -ascii $neg] "-"]"
185        }
186
187        set composite_version "$version$pos_str$neg_str"
188    }
189
190    return $composite_version
191}
192
193
194proc split_variants {variants} {
195    set result {}
196    set l [regexp -all -inline -- {([-+])([[:alpha:]_]+[\w\.]*)} $variants]
197    foreach { match sign variant } $l {
198        lappend result $variant $sign
199    }
200    return $result
201}
202
203
204##
205# Maps friendly field names to their real name
206# Names which do not need mapping are not changed.
207#
208# @param field friendly name
209# @return real name
210proc map_friendly_field_names { field } {
211    switch -- $field {
212        variant -
213        platform -
214        maintainer {
215            set field "${field}s"
216        }
217        category {
218            set field "categories"
219        }
220    }
221
222    return $field
223}
224
225
226proc registry_installed {portname {portversion ""}} {
227    set ilist [registry::installed $portname $portversion]
228    if { [llength $ilist] > 1 } {
229        # set portname again since the one we were passed may not have had the correct case
230        set portname [lindex [lindex $ilist 0] 0]
231        if {![macports::ui_isset ports_quiet] && [isatty stdout]} {
232            puts "The following versions of $portname are currently installed:"
233        }
234        foreach i [portlist_sortint $ilist] { 
235            set iname [lindex $i 0]
236            set iversion [lindex $i 1]
237            set irevision [lindex $i 2]
238            set ivariants [lindex $i 3]
239            set iactive [lindex $i 4]
240            if { $iactive == 0 } {
241                puts "  $iname ${iversion}_${irevision}${ivariants}"
242            } elseif { $iactive == 1 } {
243                puts "  $iname ${iversion}_${irevision}${ivariants} (active)"
244            }
245        }
246        return -code error "Registry error: Please specify the full version as recorded in the port registry."
247    } else {
248        return [lindex $ilist 0]
249    }
250}
251
252
253proc add_to_portlist {listname portentry} {
254    upvar $listname portlist
255    global global_options global_variations
256
257    # The portlist currently has the following elements in it:
258    #   url             if any
259    #   name
260    #   version         (version_revision)
261    #   variants array  (variant=>+-)
262    #   options array   (key=>value)
263    #   fullname        (name/version_revision+-variants)
264
265    array set port $portentry
266    if {![info exists port(url)]}       { set port(url) "" }
267    if {![info exists port(name)]}      { set port(name) "" }
268    if {![info exists port(version)]}   { set port(version) "" }
269    if {![info exists port(variants)]}  { set port(variants) "" }
270    if {![info exists port(options)]}   { set port(options) [array get global_options] }
271
272    # If neither portname nor url is specified, then default to the current port
273    if { $port(url) == "" && $port(name) == "" } {
274        set url file://.
275        set portname [url_to_portname $url]
276        set port(url) $url
277        set port(name) $portname
278        if {$portname == ""} {
279            ui_error "A default port name could not be supplied."
280        }
281    }
282
283
284    # Form the fully descriminated portname: portname/version_revison+-variants
285    set port(fullname) "$port(name)/[composite_version $port(version) $port(variants)]"
286   
287    # Add it to our portlist
288    lappend portlist [array get port]
289}
290
291
292proc add_ports_to_portlist {listname ports {overridelist ""}} {
293    upvar $listname portlist
294
295    array set overrides $overridelist
296
297    # Add each entry to the named portlist, overriding any values
298    # specified as overrides
299    foreach portentry $ports {
300        array set port $portentry
301        if ([info exists overrides(version)])   { set port(version) $overrides(version) }
302        if ([info exists overrides(variants)])  { set port(variants) $overrides(variants)   }
303        if ([info exists overrides(options)])   { set port(options) $overrides(options) }
304        add_to_portlist portlist [array get port]
305    }
306}
307
308
309proc url_to_portname { url {quiet 0} } {
310    # Save directory and restore the directory, since mportopen changes it
311    set savedir [pwd]
312    set portname ""
313    if {[catch {set ctx [mportopen $url]} result]} {
314        if {!$quiet} {
315            ui_msg "Can't map the URL '$url' to a port description file (\"${result}\")."
316            ui_msg "Please verify that the directory and portfile syntax are correct."
317        }
318    } else {
319        array set portinfo [mportinfo $ctx]
320        set portname $portinfo(name)
321        mportclose $ctx
322    }
323    cd $savedir
324    return $portname
325}
326
327
328# Supply a default porturl/portname if the portlist is empty
329proc require_portlist { nameportlist } {
330    global private_options
331    upvar $nameportlist portlist
332
333    if {[llength $portlist] == 0 && (![info exists private_options(ports_no_args)] || $private_options(ports_no_args) == "no")} {
334        ui_error "No ports found"
335        return 1
336    }
337
338    if {[llength $portlist] == 0} {
339        set portlist [get_current_port]
340
341        if {[llength $portlist] == 0} {
342            # there was no port in current directory
343            return 1
344        }
345    }
346
347    return 0
348}
349
350
351# Execute the enclosed block once for every element in the portlist
352# When the block is entered, the variables portname, portversion, options, and variations
353# will have been set
354proc foreachport {portlist block} {
355    # Restore cwd after each port, since mportopen changes it, and relative
356    # urls will break on subsequent passes
357    set savedir [pwd]
358    foreach portspec $portlist {
359        uplevel 1 "array set portspec { $portspec }"
360        uplevel 1 {
361            set porturl $portspec(url)
362            set portname $portspec(name)
363            set portversion $portspec(version)
364            array unset variations
365            array set variations $portspec(variants)
366            array unset options
367            array set options $portspec(options)
368        }
369        uplevel 1 $block
370        if {[file exists $savedir]} {
371            cd $savedir
372        } else {
373            cd ~
374        }
375    }
376}
377
378
379proc portlist_compare { a b } {
380    array set a_ $a
381    array set b_ $b
382    set namecmp [string compare -nocase $a_(name) $b_(name)]
383    if {$namecmp != 0} {
384        return $namecmp
385    }
386    set avr_ [split $a_(version) "_"]
387    set bvr_ [split $b_(version) "_"]
388    set vercmp [rpm-vercomp [lindex $avr_ 0] [lindex $bvr_ 0]]
389    if {$vercmp != 0} {
390        return $vercmp
391    }
392    set ar_ [lindex $avr_ 1]
393    set br_ [lindex $bvr_ 1]
394    if {$ar_ < $br_} {
395        return -1
396    } elseif {$ar_ > $br_} {
397        return 1
398    } else {
399        return 0
400    }
401}
402
403# Sort two ports in NVR (name@version_revision) order
404proc portlist_sort { list } {
405    return [lsort -command portlist_compare $list]
406}
407
408proc portlist_compareint { a b } {
409    array set a_ [list "name" [lindex $a 0] "version" "[lindex $a 1]_[lindex $a 2]"]
410    array set b_ [list "name" [lindex $b 0] "version" "[lindex $b 1]_[lindex $b 2]"]
411    return [portlist_compare [array get a_] [array get b_]]
412}
413
414# Same as portlist_sort, but with numeric indexes {name version revision}
415proc portlist_sortint { list } {
416    return [lsort -command portlist_compareint $list]
417}
418
419proc regex_pat_sanitize { s } {
420    set sanitized [regsub -all {[\\(){}+$.^]} $s {\\&}]
421    return $sanitized
422}
423
424##
425# Makes sure we get the current terminal size
426proc term_init_size {} {
427    global env
428
429    if {![info exists env(COLUMNS)] || ![info exists env(LINES)]} {
430        if {[isatty stdout]} {
431            set size [term_get_size stdout]
432
433            if {![info exists env(LINES)]} {
434                set env(LINES) [lindex $size 0]
435            }
436
437            if {![info exists env(COLUMNS)]} {
438                set env(COLUMNS) [lindex $size 1]
439            }
440        }
441    }
442}
443
444##
445# Wraps a multi-line string at specified textwidth
446#
447# @see wrapline
448#
449# @param string input string
450# @param maxlen text width (0 defaults to current terminal width)
451# @param indent prepend to every line
452# @return wrapped string
453proc wrap {string maxlen {indent ""} {indentfirstline 1}} {
454    global env
455
456    if {$maxlen == 0} {
457        if {![info exists env(COLUMNS)]} {
458            # no width for wrapping
459            return $string
460        }
461        set maxlen $env(COLUMNS)
462    }
463
464    set splitstring {}
465    foreach line [split $string "\n"] {
466        lappend splitstring [wrapline $line $maxlen $indent $indentfirstline]
467    }
468    return [join $splitstring "\n"]
469}
470
471##
472# Wraps a line at specified textwidth
473#
474# @see wrap
475#
476# @param line input line
477# @param maxlen text width (0 defaults to current terminal width)
478# @param indent prepend to every line
479# @return wrapped string
480proc wrapline {line maxlen {indent ""} {indentfirstline 1}} {
481    global env
482
483    if {$maxlen == 0} {
484        if {![info exists env(COLUMNS)]} {
485            # no width for wrapping
486            return $string
487        }
488        set maxlen $env(COLUMNS)
489    }
490
491    set string [split $line " "]
492    if {$indentfirstline == 0} {
493        set newline ""
494        set maxlen [expr $maxlen - [string length $indent]]
495    } else {
496        set newline $indent
497    }
498    append newline [lindex $string 0]
499    set joiner " "
500    set first 1
501    foreach word [lrange $string 1 end] {
502        if {[string length $newline]+[string length $word] >= $maxlen} {
503            lappend lines $newline
504            set newline $indent
505            set joiner ""
506            # If indentfirstline is set to 0, reset maxlen to its
507            # original length after appending the first line to lines.
508            if {$first == 1 && $indentfirstline == 0} {
509                set maxlen [expr $maxlen + [string length $indent]]
510            }
511            set first 0
512        }
513        append newline $joiner $word
514        set joiner " "
515    }
516    lappend lines $newline
517    return [join $lines "\n"]
518}
519
520##
521# Wraps a line at a specified width with a label in front
522#
523# @see wrap
524#
525# @param label label for output
526# @param string input string
527# @param maxlen text width (0 defaults to current terminal width)
528# @return wrapped string
529proc wraplabel {label string maxlen {indent ""}} {
530    append label ": [string repeat " " [expr [string length $indent] - [string length "$label: "]]]"
531    return "$label[wrap $string $maxlen $indent 0]"
532}
533
534proc unobscure_maintainers { list } {
535    set result {}
536    foreach m $list {
537        if {[string first "@" $m] < 0} {
538            if {[string first ":" $m] >= 0} {
539                set m [regsub -- "(.*):(.*)" $m "\\2@\\1"] 
540            } else {
541                set m "$m@macports.org"
542            }
543        }
544        lappend result $m
545    }
546    return $result
547}
548
549
550##########################################
551# Port selection
552##########################################
553proc get_matching_ports {pattern {casesensitive no} {matchstyle glob} {field name}} {
554    if {[catch {set res [mportsearch $pattern $casesensitive $matchstyle $field]} result]} {
555        global errorInfo
556        ui_debug "$errorInfo"
557        fatal "search for portname $pattern failed: $result"
558    }
559
560    set results {}
561    foreach {name info} $res {
562        array unset portinfo
563        array set portinfo $info
564
565        #set variants {}
566        #if {[info exists portinfo(variants)]} {
567        #   foreach variant $portinfo(variants) {
568        #       lappend variants $variant "+"
569        #   }
570        #}
571        # For now, don't include version or variants with all ports list
572        #"$portinfo(version)_$portinfo(revision)"
573        #$variants
574        add_to_portlist results [list url $portinfo(porturl) name $name]
575    }
576
577    # Return the list of all ports, sorted
578    return [portlist_sort $results]
579}
580
581
582proc get_all_ports {} {
583    global all_ports_cache
584
585    if {![info exists all_ports_cache]} {
586        set all_ports_cache [get_matching_ports "*"]
587    }
588    return $all_ports_cache
589}
590
591
592proc get_current_ports {} {
593    # This is just a synonym for get_current_port that
594    # works with the regex in element
595    return [get_current_port]
596}
597
598
599proc get_current_port {} {
600    set url file://.
601    set portname [url_to_portname $url]
602    if {$portname == ""} {
603        ui_msg "To use the current port, you must be in a port's directory."
604        ui_msg "(you might also see this message if a pseudo-port such as"
605        ui_msg "outdated or installed expands to no ports)."
606        return [list]
607    }
608
609    set results {}
610    add_to_portlist results [list url $url name $portname]
611    return $results
612}
613
614
615proc get_installed_ports { {ignore_active yes} {active yes} } {
616    set ilist {}
617    if { [catch {set ilist [registry::installed]} result] } {
618        if {$result != "Registry error: No ports registered as installed."} {
619            global errorInfo
620            ui_debug "$errorInfo"
621            fatal "port installed failed: $result"
622        }
623    }
624
625    set results {}
626    foreach i $ilist {
627        set iname [lindex $i 0]
628        set iversion [lindex $i 1]
629        set irevision [lindex $i 2]
630        set ivariants [split_variants [lindex $i 3]]
631        set iactive [lindex $i 4]
632
633        if { ${ignore_active} == "yes" || (${active} == "yes") == (${iactive} != 0) } {
634            add_to_portlist results [list name $iname version "${iversion}_${irevision}" variants $ivariants]
635        }
636    }
637
638    # Return the list of ports, sorted
639    return [portlist_sort $results]
640}
641
642
643proc get_uninstalled_ports {} {
644    # Return all - installed
645    set all [get_all_ports]
646    set installed [get_installed_ports]
647    return [opComplement $all $installed]
648}
649
650
651proc get_active_ports {} {
652    return [get_installed_ports no yes]
653}
654
655
656proc get_inactive_ports {} {
657    return [get_installed_ports no no]
658}
659
660
661proc get_outdated_ports {} {
662    global macports::registry.installtype
663    set is_image_mode [expr 0 == [string compare "image" ${macports::registry.installtype}]]
664
665    # Get the list of installed ports
666    set ilist {}
667    if { [catch {set ilist [registry::installed]} result] } {
668        if {$result != "Registry error: No ports registered as installed."} {
669            global errorInfo
670            ui_debug "$errorInfo"
671            fatal "port installed failed: $result"
672        }
673    }
674
675    # Now process the list, keeping only those ports that are outdated
676    set results {}
677    if { [llength $ilist] > 0 } {
678        foreach i $ilist {
679
680            # Get information about the installed port
681            set portname            [lindex $i 0]
682            set installed_version   [lindex $i 1]
683            set installed_revision  [lindex $i 2]
684            set installed_compound  "${installed_version}_${installed_revision}"
685            set installed_variants  [lindex $i 3]
686
687            set is_active           [lindex $i 4]
688            if { $is_active == 0 && $is_image_mode } continue
689
690            set installed_epoch     [lindex $i 5]
691
692            # Get info about the port from the index
693            if {[catch {set res [mportlookup $portname]} result]} {
694                global errorInfo
695                ui_debug "$errorInfo"
696                fatal "lookup of portname $portname failed: $result"
697            }
698            if {[llength $res] < 2} {
699                if {[macports::ui_isset ports_debug]} {
700                    puts stderr "$portname ($installed_compound is installed; the port was not found in the port index)"
701                }
702                continue
703            }
704            array unset portinfo
705            array set portinfo [lindex $res 1]
706
707            # Get information about latest available version and revision
708            set latest_version $portinfo(version)
709            set latest_revision     0
710            if {[info exists portinfo(revision)] && $portinfo(revision) > 0} { 
711                set latest_revision $portinfo(revision)
712            }
713            set latest_compound     "${latest_version}_${latest_revision}"
714            set latest_epoch        0
715            if {[info exists portinfo(epoch)]} { 
716                set latest_epoch    $portinfo(epoch)
717            }
718
719            # Compare versions, first checking epoch, then version, then revision
720            set comp_result [expr $installed_epoch - $latest_epoch]
721            if { $comp_result == 0 } {
722                set comp_result [rpm-vercomp $installed_version $latest_version]
723                if { $comp_result == 0 } {
724                    set comp_result [rpm-vercomp $installed_revision $latest_revision]
725                }
726            }
727
728            # Add outdated ports to our results list
729            if { $comp_result < 0 } {
730                add_to_portlist results [list name $portname version $installed_compound variants [split_variants $installed_variants]]
731            }
732        }
733    }
734
735    return $results
736}
737
738
739proc get_obsolete_ports {} {
740    set ilist [get_installed_ports]
741    set results {}
742
743    foreach i $ilist {
744        array set port $i
745
746        if {[catch {mportlookup $port(name)} result]} {
747            ui_debug "$::errorInfo"
748            break_softcontinue "lookup of portname $portname failed: $result" 1 status
749        }
750
751        if {[llength $result] < 2} {
752            lappend results $i
753        }
754    }
755
756    # Return the list of ports, already sorted
757    return [portlist_sort $results]
758}
759
760
761##########################################
762# Port expressions
763##########################################
764proc portExpr { resname } {
765    upvar $resname reslist
766    set result [seqExpr reslist]
767    return $result
768}
769
770
771proc seqExpr { resname } {
772    upvar $resname reslist
773   
774    # Evaluate a sequence of expressions a b c...
775    # These act the same as a or b or c
776
777    set result 1
778    while {$result} {
779        switch -- [lookahead] {
780            ;       -
781            )       -
782            _EOF_   { break }
783        }
784
785        set blist {}
786        set result [orExpr blist]
787        if {$result} {
788            # Calculate the union of result and b
789            set reslist [opUnion $reslist $blist]
790        }
791    }
792
793    return $result
794}
795
796
797proc orExpr { resname } {
798    upvar $resname reslist
799   
800    set a [andExpr reslist]
801    while ($a) {
802        switch -- [lookahead] {
803            or {
804                    advance
805                    set blist {}
806                    if {![andExpr blist]} {
807                        return 0
808                    }
809                       
810                    # Calculate a union b
811                    set reslist [opUnion $reslist $blist]
812                }
813            default {
814                    return $a
815                }
816        }
817    }
818   
819    return $a
820}
821
822
823proc andExpr { resname } {
824    upvar $resname reslist
825   
826    set a [unaryExpr reslist]
827    while {$a} {
828        switch -- [lookahead] {
829            and {
830                    advance
831                   
832                    set blist {}
833                    set b [unaryExpr blist]
834                    if {!$b} {
835                        return 0
836                    }
837                   
838                    # Calculate a intersect b
839                    set reslist [opIntersection $reslist $blist]
840                }
841            default {
842                    return $a
843                }
844        }
845    }
846   
847    return $a
848}
849
850
851proc unaryExpr { resname } {
852    upvar $resname reslist
853    set result 0
854
855    switch -- [lookahead] {
856        !   -
857        not {
858                advance
859                set blist {}
860                set result [unaryExpr blist]
861                if {$result} {
862                    set all [get_all_ports]
863                    set reslist [opComplement $all $blist]
864                }
865            }
866        default {
867                set result [element reslist]
868            }
869    }
870   
871    return $result
872}
873
874
875proc element { resname } {
876    upvar $resname reslist
877    set el 0
878   
879    set url ""
880    set name ""
881    set version ""
882    array unset variants
883    array unset options
884   
885    set token [lookahead]
886    switch -regex -- $token {
887        ^\\)$               -
888        ^\;                 -
889        ^_EOF_$             { # End of expression/cmd/file
890        }
891
892        ^\\($               { # Parenthesized Expression
893            advance
894            set el [portExpr reslist]
895            if {!$el || ![match ")"]} {
896                set el 0
897            }
898        }
899
900        ^all(@.*)?$         -
901        ^installed(@.*)?$   -
902        ^uninstalled(@.*)?$ -
903        ^active(@.*)?$      -
904        ^inactive(@.*)?$    -
905        ^outdated(@.*)?$    -
906        ^obsolete(@.*)?$    -
907        ^current(@.*)?$     {
908            # A simple pseudo-port name
909            advance
910
911            # Break off the version component, if there is one
912            regexp {^(\w+)(@.*)?} $token matchvar name remainder
913
914            add_multiple_ports reslist [get_${name}_ports] $remainder
915
916            set el 1
917        }
918
919        ^variants:          -
920        ^variant:           -
921        ^description:       -
922        ^portdir:           -
923        ^homepage:          -
924        ^epoch:             -
925        ^platforms:         -
926        ^platform:          -
927        ^name:              -
928        ^long_description:  -
929        ^maintainers:       -
930        ^maintainer:        -
931        ^categories:        -
932        ^category:          -
933        ^version:           -
934        ^depends_lib:       -
935        ^depends_build:     -
936        ^depends_run:       -
937        ^depends_extract:   -
938        ^depends_fetch:     -
939        ^revision:          { # Handle special port selectors
940            advance
941
942            # Break up the token, because older Tcl switch doesn't support -matchvar
943            regexp {^(\w+):(.*)} $token matchvar field pat
944
945            # Remap friendly names to actual names
946            set field [map_friendly_field_names $field]
947
948            add_multiple_ports reslist [get_matching_ports $pat no regexp $field]
949            set el 1
950        }
951
952        ^depends:           { # A port selector shorthand for depends_{lib,build,run,fetch,extract}
953            advance
954
955            # Break up the token, because older Tcl switch doesn't support -matchvar
956            regexp {^(\w+):(.*)} $token matchvar field pat
957
958            add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_lib"]
959            add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_build"]
960            add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_run"]
961            add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_extract"]
962            add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_fetch"]
963
964            set el 1
965        }
966
967        [][?*]              { # Handle portname glob patterns
968            advance; add_multiple_ports reslist [get_matching_ports $token no glob]
969            set el 1
970        }
971
972        ^\\w+:.+            { # Handle a url by trying to open it as a port and mapping the name
973            advance
974            set name [url_to_portname $token]
975            if {$name != ""} {
976                parsePortSpec version variants options
977                add_to_portlist reslist [list url $token \
978                  name $name \
979                  version $version \
980                  variants [array get variants] \
981                  options [array get options]]
982            } else {
983                ui_error "Can't open URL '$token' as a port"
984                set el 0
985            }
986            set el 1
987        }
988
989        default             { # Treat anything else as a portspec (portname, version, variants, options
990            # or some combination thereof).
991            parseFullPortSpec url name version variants options
992            add_to_portlist reslist [list url $url \
993              name $name \
994              version $version \
995              variants [array get variants] \
996              options [array get options]]
997            set el 1
998        }
999    }
1000
1001    return $el
1002}
1003
1004
1005proc add_multiple_ports { resname ports {remainder ""} } {
1006    upvar $resname reslist
1007   
1008    set version ""
1009    array unset variants
1010    array unset options
1011    parsePortSpec version variants options $remainder
1012   
1013    array unset overrides
1014    if {$version != ""} { set overrides(version) $version }
1015    if {[array size variants]} { set overrides(variants) [array get variants] }
1016    if {[array size options]} { set overrides(options) [array get options] }
1017
1018    add_ports_to_portlist reslist $ports [array get overrides]
1019}
1020
1021
1022proc opUnion { a b } {
1023    set result {}
1024   
1025    array unset onetime
1026   
1027    # Walk through each array, adding to result only those items that haven't
1028    # been added before
1029    foreach item $a {
1030        array set port $item
1031        if {[info exists onetime($port(fullname))]} continue
1032        set onetime($port(fullname)) 1
1033        lappend result $item
1034    }
1035
1036    foreach item $b {
1037        array set port $item
1038        if {[info exists onetime($port(fullname))]} continue
1039        set onetime($port(fullname)) 1
1040        lappend result $item
1041    }
1042   
1043    return $result
1044}
1045
1046
1047proc opIntersection { a b } {
1048    set result {}
1049   
1050    # Rules we follow in performing the intersection of two port lists:
1051    #
1052    #   a/, a/          ==> a/
1053    #   a/, b/          ==>
1054    #   a/, a/1.0       ==> a/1.0
1055    #   a/1.0, a/       ==> a/1.0
1056    #   a/1.0, a/2.0    ==>
1057    #
1058    #   If there's an exact match, we take it.
1059    #   If there's a match between simple and descriminated, we take the later.
1060   
1061    # First create a list of the fully descriminated names in b
1062    array unset bfull
1063    set i 0
1064    foreach bitem $b {
1065        array set port $bitem
1066        set bfull($port(fullname)) $i
1067        incr i
1068    }
1069   
1070    # Walk through each item in a, matching against b
1071    foreach aitem $a {
1072        array set port $aitem
1073       
1074        # Quote the fullname and portname to avoid special characters messing up the regexp
1075        set safefullname [regex_pat_sanitize $port(fullname)]
1076       
1077        set simpleform [expr { "$port(name)/" == $port(fullname) }]
1078        if {$simpleform} {
1079            set pat "^${safefullname}"
1080        } else {
1081            set safename [regex_pat_sanitize $port(name)]
1082            set pat "^${safefullname}$|^${safename}/$"
1083        }
1084       
1085        set matches [array names bfull -regexp $pat]
1086        foreach match $matches {
1087            if {$simpleform} {
1088                set i $bfull($match)
1089                lappend result [lindex $b $i]
1090            } else {
1091                lappend result $aitem
1092            }
1093        }
1094    }
1095   
1096    return $result
1097}
1098
1099
1100proc opComplement { a b } {
1101    set result {}
1102   
1103    # Return all elements of a not matching elements in b
1104   
1105    # First create a list of the fully descriminated names in b
1106    array unset bfull
1107    set i 0
1108    foreach bitem $b {
1109        array set port $bitem
1110        set bfull($port(fullname)) $i
1111        incr i
1112    }
1113   
1114    # Walk through each item in a, taking all those items that don't match b
1115    #
1116    # Note: -regexp may not be present in all versions of Tcl we need to work
1117    #       against, in which case we may have to fall back to a slower alternative
1118    #       for those cases. I'm not worrying about that for now, however. -jdb
1119    foreach aitem $a {
1120        array set port $aitem
1121       
1122        # Quote the fullname and portname to avoid special characters messing up the regexp
1123        set safefullname [regex_pat_sanitize $port(fullname)]
1124       
1125        set simpleform [expr { "$port(name)/" == $port(fullname) }]
1126        if {$simpleform} {
1127            set pat "^${safefullname}"
1128        } else {
1129            set safename [regex_pat_sanitize $port(name)]
1130            set pat "^${safefullname}$|^${safename}/$"
1131        }
1132       
1133        set matches [array names bfull -regexp $pat]
1134
1135        # We copy this element to result only if it didn't match against b
1136        if {![llength $matches]} {
1137            lappend result $aitem
1138        }
1139    }
1140   
1141    return $result
1142}
1143
1144
1145proc parseFullPortSpec { urlname namename vername varname optname } {
1146    upvar $urlname porturl
1147    upvar $namename portname
1148    upvar $vername portversion
1149    upvar $varname portvariants
1150    upvar $optname portoptions
1151   
1152    set portname ""
1153    set portversion ""
1154    array unset portvariants
1155    array unset portoptions
1156   
1157    if { [moreargs] } {
1158        # Look first for a potential portname
1159        #
1160        # We need to allow a wide variaty of tokens here, because of actions like "provides"
1161        # so we take a rather lenient view of what a "portname" is. We allow
1162        # anything that doesn't look like either a version, a variant, or an option
1163        set token [lookahead]
1164
1165        set remainder ""
1166        if {![regexp {^(@|[-+]([[:alpha:]_]+[\w\.]*)|[[:alpha:]_]+[\w\.]*=)} $token match]} {
1167            advance
1168            regexp {^([^@]+)(@.*)?} $token match portname remainder
1169           
1170            # If the portname contains a /, then try to use it as a URL
1171            if {[string match "*/*" $portname]} {
1172                set url "file://$portname"
1173                set name [url_to_portname $url 1]
1174                if { $name != "" } {
1175                    # We mapped the url to valid port
1176                    set porturl $url
1177                    set portname $name
1178                    # Continue to parse rest of portspec....
1179                } else {
1180                    # We didn't map the url to a port; treat it
1181                    # as a raw string for something like port contents
1182                    # or cd
1183                    set porturl ""
1184                    # Since this isn't a port, we don't try to parse
1185                    # any remaining portspec....
1186                    return
1187                }
1188            }
1189        }
1190       
1191        # Now parse the rest of the spec
1192        parsePortSpec portversion portvariants portoptions $remainder
1193    }
1194}
1195
1196   
1197proc parsePortSpec { vername varname optname {remainder ""} } {
1198    upvar $vername portversion
1199    upvar $varname portvariants
1200    upvar $optname portoptions
1201   
1202    global global_options
1203   
1204    set portversion ""
1205    array unset portoptions
1206    array set portoptions [array get global_options]
1207    array unset portvariants
1208   
1209    # Parse port version/variants/options
1210    set opt $remainder
1211    set adv 0
1212    set consumed 0
1213    for {set firstTime 1} {$opt != "" || [moreargs]} {set firstTime 0} {
1214   
1215        # Refresh opt as needed
1216        if {$opt == ""} {
1217            if {$adv} advance
1218            set opt [lookahead]
1219            set adv 1
1220            set consumed 0
1221        }
1222       
1223        # Version must be first, if it's there at all
1224        if {$firstTime && [string match {@*} $opt]} {
1225            # Parse the version
1226           
1227            # Strip the @
1228            set opt [string range $opt 1 end]
1229           
1230            # Handle the version
1231            set sepPos [string first "/" $opt]
1232            if {$sepPos >= 0} {
1233                # Version terminated by "/" to disambiguate -variant from part of version
1234                set portversion [string range $opt 0 [expr $sepPos-1]]
1235                set opt [string range $opt [expr $sepPos+1] end]
1236            } else {
1237                # Version terminated by "+", or else is complete
1238                set sepPos [string first "+" $opt]
1239                if {$sepPos >= 0} {
1240                    # Version terminated by "+"
1241                    set portversion [string range $opt 0 [expr $sepPos-1]]
1242                    set opt [string range $opt $sepPos end]
1243                } else {
1244                    # Unterminated version
1245                    set portversion $opt
1246                    set opt ""
1247                }
1248            }
1249            set consumed 1
1250        } else {
1251            # Parse all other options
1252           
1253            # Look first for a variable setting: VARNAME=VALUE
1254            if {[regexp {^([[:alpha:]_]+[\w\.]*)=(.*)} $opt match key val] == 1} {
1255                # It's a variable setting
1256                set portoptions($key) "\"$val\""
1257                set opt ""
1258                set consumed 1
1259            } elseif {[regexp {^([-+])([[:alpha:]_]+[\w\.]*)} $opt match sign variant] == 1} {
1260                # It's a variant
1261                set portvariants($variant) $sign
1262                set opt [string range $opt [expr [string length $variant]+1] end]
1263                set consumed 1
1264            } else {
1265                # Not an option we recognize, so break from port option processing
1266                if { $consumed && $adv } advance
1267                break
1268            }
1269        }
1270    }
1271}
1272
1273
1274##########################################
1275# Action Handlers
1276##########################################
1277
1278proc action_get_usage { action } {
1279    global action_array cmd_opts_array
1280
1281    if {[info exists action_array($action)]} {
1282        set cmds ""
1283        if {[info exists cmd_opts_array($action)]} {
1284            foreach opt $cmd_opts_array($action) {
1285                if {[llength $opt] == 1} {
1286                    set name $opt
1287                    set optc 0
1288                } else {
1289                    set name [lindex $opt 0]
1290                    set optc [lindex $opt 1]
1291                }
1292
1293                append cmds " --$name"
1294
1295                for {set i 1} {$i <= $optc} {incr i} {
1296                    append cmds " <arg$i>"
1297                }
1298            }
1299        }
1300        set args ""
1301        set needed [action_needs_portlist $action]
1302        if {[action_args_const strings] == $needed} {
1303            set args " <arguments>"
1304        } elseif {[action_args_const strings] == $needed} {
1305            set args " <portlist>"
1306        }
1307
1308        set ret "Usage: "
1309        set len [string length $action]
1310        append ret [wrap "$action$cmds$args" 0 [string repeat " " [expr 8 + $len]] 0]
1311        append ret "\n"
1312
1313        return $ret
1314    }
1315
1316    return -1
1317}
1318
1319proc action_usage { action portlist opts } {
1320    if {[llength $portlist] == 0} {
1321        print_usage
1322        return 0
1323    }
1324
1325    foreach topic $portlist {
1326        set usage [action_get_usage $topic]
1327        if {$usage != -1} {
1328           puts -nonewline stderr $usage
1329        } else {
1330            ui_error "No usage for topic $topic"
1331            return 1
1332        }
1333    }
1334}
1335
1336
1337proc action_help { action portlist opts } {
1338    set helpfile "$macports::prefix/var/macports/port-help.tcl"
1339
1340    if {[llength $portlist] == 0} {
1341        print_help
1342        return 0
1343    }
1344
1345    if {[file exists $helpfile]} {
1346        if {[catch {source $helpfile} err]} {
1347            puts stderr "Error reading helpfile $helpfile: $err"
1348            return 1
1349        }
1350    } else {
1351        puts stderr "Unable to open help file $helpfile"
1352        return 1
1353    }
1354
1355    foreach topic $portlist {
1356        if {![info exists porthelp($topic)]} {
1357            puts stderr "No help for topic $topic"
1358            return 1
1359        }
1360
1361        set usage [action_get_usage $topic]
1362        if {$usage != -1} {
1363           puts -nonewline stderr $usage
1364        } else {
1365            ui_error "No usage for topic $topic"
1366            return 1
1367        }
1368
1369        puts stderr $porthelp($topic)
1370    }
1371
1372    return 0
1373}
1374
1375
1376proc action_log { action portlist opts } {
1377    set logfile "$macports::prefix/var/macports/logs/"
1378
1379    if {[llength $portlist] == 0} {
1380        print_help
1381        return 0
1382    }
1383    foreachport $portlist {
1384        # If we have a url, use that, since it's most specific
1385        # otherwise try to map the portname to a url
1386        if {$porturl eq ""} {
1387        # Verify the portname, getting portinfo to map to a porturl
1388            if {[catch {mportlookup $portname} result]} {
1389                ui_debug "$::errorInfo"
1390                break_softcontinue "lookup of portname $portname failed: $result" 1 status
1391            }
1392            if {[llength $result] < 2} {
1393                break_softcontinue "Port $portname not found" 1 status
1394            }
1395            array unset portinfo
1396            array set portinfo [lindex $result 1]
1397            set porturl $portinfo(porturl)
1398            set portdir $portinfo(portdir)
1399        } elseif {$porturl ne "file://."} {
1400            # Extract the portdir from porturl and use it to search PortIndex.
1401            # Only the last two elements of the path (porturl) make up the
1402            # portdir.
1403            set portdir [file split [macports::getportdir $porturl]]
1404            set lsize [llength $portdir]
1405            set portdir \
1406                [file join [lindex $portdir [expr $lsize - 2]] \
1407                           [lindex $portdir [expr $lsize - 1]]]
1408            if {[catch {mportsearch $portdir no exact portdir} result]} {
1409                ui_debug "$::errorInfo"
1410                break_softcontinue "Portdir $portdir not found" 1 status
1411            }
1412            if {[llength $result] < 2} {
1413                break_softcontinue "Portdir $portdir not found" 1 status
1414            }
1415            array unset portinfo
1416            array set portinfo [lindex $result 1]
1417        }
1418        if {[catch {set mport [mportopen $porturl [array get options] [array get merged_variations]]} result]} {
1419            ui_debug "$::errorInfo"
1420            break_softcontinue "Unable to open port: $result" 1 status
1421         }
1422         array unset portinfo
1423         array set portinfo [mportinfo $mport]
1424
1425         append logfile $portinfo(name)
1426         append logfile "/main.log"
1427         mportclose $mport                       
1428         set fp [open $logfile r]
1429         set data [read $fp]
1430         close $fp
1431         puts $data
1432    }
1433    return 0
1434}
1435
1436
1437proc action_info { action portlist opts } {
1438    global global_variations
1439    set status 0
1440    if {[require_portlist portlist]} {
1441        return 1
1442    }
1443
1444    set separator ""
1445    foreachport $portlist {
1446        puts -nonewline $separator
1447        # If we have a url, use that, since it's most specific
1448        # otherwise try to map the portname to a url
1449        if {$porturl eq ""} {
1450        # Verify the portname, getting portinfo to map to a porturl
1451            if {[catch {mportlookup $portname} result]} {
1452                ui_debug "$::errorInfo"
1453                break_softcontinue "lookup of portname $portname failed: $result" 1 status
1454            }
1455            if {[llength $result] < 2} {
1456                break_softcontinue "Port $portname not found" 1 status
1457            }
1458            array unset portinfo
1459            array set portinfo [lindex $result 1]
1460            set porturl $portinfo(porturl)
1461            set portdir $portinfo(portdir)
1462        } elseif {$porturl ne "file://."} {
1463            # Extract the portdir from porturl and use it to search PortIndex.
1464            # Only the last two elements of the path (porturl) make up the
1465            # portdir.
1466            set portdir [file split [macports::getportdir $porturl]]
1467            set lsize [llength $portdir]
1468            set portdir \
1469                [file join [lindex $portdir [expr $lsize - 2]] \
1470                           [lindex $portdir [expr $lsize - 1]]]
1471            if {[catch {mportsearch $portdir no exact portdir} result]} {
1472                ui_debug "$::errorInfo"
1473                break_softcontinue "Portdir $portdir not found" 1 status
1474            }
1475            if {[llength $result] < 2} {
1476                break_softcontinue "Portdir $portdir not found" 1 status
1477            }
1478            array unset portinfo
1479            array set portinfo [lindex $result 1]
1480        }
1481
1482        if {!([info exists options(ports_info_index)] && $options(ports_info_index) eq "yes")} {
1483            # Add any global_variations to the variations
1484            # specified for the port (so we get e.g. dependencies right)
1485            array unset merged_variations
1486            array set merged_variations [array get variations]
1487            foreach { variation value } [array get global_variations] { 
1488                if { ![info exists merged_variations($variation)] } { 
1489                    set merged_variations($variation) $value 
1490                } 
1491            }
1492 
1493            if {[catch {set mport [mportopen $porturl [array get options] [array get merged_variations]]} result]} {
1494                ui_debug "$::errorInfo"
1495                break_softcontinue "Unable to open port: $result" 1 status
1496            }
1497            array unset portinfo
1498            array set portinfo [mportinfo $mport]
1499            mportclose $mport
1500            if {[info exists portdir]} {
1501                set portinfo(portdir) $portdir
1502            }
1503        } elseif {![info exists portinfo]} {
1504            ui_warn "port info --index does not work with 'current' pseudo-port"
1505            continue
1506        }
1507        array unset options ports_info_index
1508
1509        # Understand which info items are actually lists
1510        # (this could be overloaded to provide a generic formatting code to
1511        # allow us to, say, split off the prefix on libs)
1512        array set list_map "
1513            categories      1
1514            depends_fetch   1
1515            depends_extract 1
1516            depends_build   1
1517            depends_lib     1
1518            depends_run     1
1519            maintainers     1
1520            platforms       1
1521            variants        1
1522            conflicts       1
1523        "
1524
1525        # Label map for pretty printing
1526        array set pretty_label {
1527            heading     ""
1528            variants    Variants
1529            depends_fetch "Fetch Dependencies"
1530            depends_extract "Extract Dependencies"
1531            depends_build "Build Dependencies"
1532            depends_run "Runtime Dependencies"
1533            depends_lib "Library Dependencies"
1534            description "Brief Description"
1535            long_description "Description"
1536            fullname    "Full Name: "
1537            homepage    Homepage
1538            platforms   Platforms
1539            maintainers Maintainers
1540            license     License
1541            conflicts   "Conflicts with"
1542        }
1543
1544        # Wrap-length map for pretty printing
1545        array set pretty_wrap {
1546            heading 0
1547            variants 22
1548            depends_fetch 22
1549            depends_extract 22
1550            depends_build 22
1551            depends_run 22
1552            depends_lib 22
1553            description 22
1554            long_description 22
1555            homepage 22
1556            platforms 22
1557            license 22
1558            conflicts 22
1559            maintainers 22
1560        }
1561
1562        # Interpret a convenient field abbreviation
1563        if {[info exists options(ports_info_depends)] && $options(ports_info_depends) == "yes"} {
1564            array unset options ports_info_depends
1565            set options(ports_info_depends_fetch) yes
1566            set options(ports_info_depends_extract) yes
1567            set options(ports_info_depends_build) yes
1568            set options(ports_info_depends_lib) yes
1569            set options(ports_info_depends_run) yes
1570        }
1571               
1572        # Set up our field separators
1573        set show_label 1
1574        set field_sep "\n"
1575        set subfield_sep ", "
1576        set pretty_print 0
1577       
1578        # For human-readable summary, which is the default with no options
1579        if {![array size options]} {
1580            set pretty_print 1
1581        } elseif {[info exists options(ports_info_pretty)]} {
1582            set pretty_print 1
1583            array unset options ports_info_pretty
1584        }
1585
1586        # Tune for sort(1)
1587        if {[info exists options(ports_info_line)]} {
1588            array unset options ports_info_line
1589            set show_label 0
1590            set field_sep "\t"
1591            set subfield_sep ","
1592        }
1593       
1594        # Figure out whether to show field name
1595        set quiet [macports::ui_isset ports_quiet]
1596        if {$quiet} {
1597            set show_label 0
1598        }
1599        # In pretty-print mode we also suppress messages, even though we show
1600        # most of the labels:
1601        if {$pretty_print} {
1602            set quiet 1
1603        }
1604
1605        # Spin through action options, emitting information for any found
1606        set fields {}
1607        set opts_todo [array names options ports_info_*]
1608        set fields_tried {}
1609        if {![llength $opts_todo]} {
1610            set opts_todo {ports_info_heading ports_info_variants
1611                ports_info_skip_line
1612                ports_info_long_description ports_info_homepage
1613                ports_info_skip_line ports_info_depends_fetch
1614                ports_info_depends_extract ports_info_depends_build
1615                ports_info_depends_lib ports_info_depends_run
1616                ports_info_conflicts
1617                ports_info_platforms ports_info_license
1618                ports_info_maintainers
1619            }
1620        }
1621        foreach { option } $opts_todo {
1622            set opt [string range $option 11 end]
1623            # Artificial field name for formatting
1624            if {$pretty_print && $opt eq "skip_line"} {
1625                lappend fields ""
1626                continue
1627            }
1628            # Artificial field names to reproduce prettyprinted summary
1629            if {$opt eq "heading"} {
1630                set inf "$portinfo(name) @$portinfo(version)"
1631                set ropt "heading"
1632                if {[info exists portinfo(revision)] && $portinfo(revision) > 0} {
1633                    append inf ", Revision $portinfo(revision)"
1634                }
1635                if {[info exists portinfo(categories)]} {
1636                    append inf " ([join $portinfo(categories) ", "])"
1637                }
1638            } elseif {$opt eq "fullname"} {
1639                set inf "$portinfo(name) @"
1640                append inf [composite_version $portinfo(version) $portinfo(active_variants)]
1641                set ropt "fullname"
1642            } else {
1643                # Map from friendly name
1644                set ropt [map_friendly_field_names $opt]
1645               
1646                # If there's no such info, move on
1647                if {![info exists portinfo($ropt)]} {
1648                    set inf ""
1649                } else {
1650                    set inf [join $portinfo($ropt)]
1651                }
1652            }
1653
1654            # Calculate field label
1655            set label ""
1656            if {$pretty_print} {
1657                if {[info exists pretty_label($ropt)]} {
1658                    set label $pretty_label($ropt)
1659                } else {
1660                    set label $opt
1661                }
1662            } elseif {$show_label} {
1663                set label "$opt: "
1664            }
1665           
1666            # Format the data
1667            if { $ropt eq "maintainers" } {
1668                set inf [unobscure_maintainers $inf]
1669            }
1670            #     ... special formatting for certain fields when prettyprinting
1671            if {$pretty_print} {
1672                if {$ropt eq "variants"} {
1673                    # Use the new format for variants iff it exists in
1674                    # PortInfo. This key currently does not exist outside of
1675                    # trunk (1.8.0).
1676                    array unset vinfo
1677                    if {[info exists portinfo(vinfo)]} {
1678                        array set vinfo $portinfo(vinfo)
1679                    }
1680
1681                    set pi_vars $inf
1682                    set inf {}
1683                    foreach v [lsort $pi_vars] {
1684                        set varmodifier ""
1685                        if {[info exists variations($v)]} {
1686                            # selected by command line, prefixed with +/-
1687                            set varmodifier $variations($v)
1688                        } elseif {[info exists global_variations($v)]} {
1689                            # selected by variants.conf, prefixed with (+)/(-)
1690                            set varmodifier "($global_variations($v))"
1691                            # Retrieve additional information from the new key.
1692                        } elseif {[info exists vinfo]} {
1693                            array unset variant
1694                            array set variant $vinfo($v)
1695                            if {[info exists variant(is_default)]} {
1696                                set varmodifier "\[+]"
1697                            }
1698                        }
1699                        lappend inf "$varmodifier$v"
1700                    }
1701                } elseif {[string match "depend*" $ropt] 
1702                          && ![macports::ui_isset ports_verbose]} {
1703                    set pi_deps $inf
1704                    set inf {}
1705                    foreach d $pi_deps {
1706                        lappend inf [lindex [split $d :] end]
1707                    }
1708                }
1709            } 
1710            #End of special pretty-print formatting for certain fields
1711            if [info exists list_map($ropt)] {
1712                set field [join $inf $subfield_sep]
1713            } else {
1714                set field $inf
1715            }
1716           
1717            # Assemble the entry
1718            if {$pretty_print} {
1719                # The two special fields are considered headings and are
1720                # emitted immediately, rather than waiting. Also they are not
1721                # recorded on the list of fields tried
1722                if {$ropt eq "heading" || $ropt eq "fullname"} {
1723                    puts "$label$field"
1724                    continue
1725                }
1726            }
1727            lappend fields_tried $label
1728            if {$pretty_print} {
1729                if {![string length $field]} {
1730                    continue
1731                }
1732                if {![string length $label]} {
1733                    set wrap_len 0
1734                    if {[info exists pretty_wrap($ropt)]} {
1735                        set wrap_len $pretty_wrap($ropt)
1736                    }
1737                    lappend fields [wrap $field 0 [string repeat " " $wrap_len]]
1738                } else {
1739                    set wrap_len [string length $label]
1740                    if {[info exists pretty_wrap($ropt)]} {
1741                        set wrap_len $pretty_wrap($ropt)
1742                    }
1743                    lappend fields [wraplabel $label $field 0 [string repeat " " $wrap_len]]
1744                }
1745
1746            } else { # Not pretty print
1747                lappend fields "$label$field"
1748            }
1749        }
1750
1751        # Now output all that information:
1752        if {[llength $fields]} {
1753            puts [join $fields $field_sep]
1754        } else {
1755            if {$pretty_print && [llength $fields_tried]} {
1756                puts -nonewline "$portinfo(name) has no "
1757                puts [join $fields_tried ", "]
1758            }
1759        }
1760        set separator "--\n"
1761    }
1762   
1763    return $status
1764}
1765
1766
1767proc action_location { action portlist opts } {
1768    set status 0
1769    if {[require_portlist portlist]} {
1770        return 1
1771    }
1772    foreachport $portlist {
1773        if { [catch {set ilist [registry_installed $portname [composite_version $portversion [array get variations]]]} result] } {
1774            global errorInfo
1775            ui_debug "$errorInfo"
1776            break_softcontinue "port location failed: $result" 1 status
1777        } else {
1778            # set portname again since the one we were passed may not have had the correct case
1779            set portname [lindex $ilist 0]
1780            set version [lindex $ilist 1]
1781            set revision [lindex $ilist 2]
1782            set variants [lindex $ilist 3]
1783        }
1784
1785        set ref [registry::open_entry $portname $version $revision $variants]
1786        if { [string equal [registry::property_retrieve $ref installtype] "image"] } {
1787            set imagedir [registry::property_retrieve $ref imagedir]
1788            if {![macports::ui_isset ports_quiet]} {
1789                puts "Port $portname ${version}_${revision}${variants} is installed as an image in:"
1790            }
1791            puts $imagedir
1792        } else {
1793            break_softcontinue "Port $portname is not installed as an image." 1 status
1794        }
1795    }
1796   
1797    return $status
1798}
1799
1800
1801proc action_notes { action portlist opts } {
1802    if {[require_portlist portlist]} {
1803        return 1
1804    }
1805
1806    foreachport $portlist {
1807        if {$porturl eq ""} {
1808            # Look up the port.
1809            if {[catch {mportlookup $portname} result]} {
1810                ui_debug $::errorInfo
1811                break_softcontinue "The lookup of '$portname' failed: $result" \
1812                                1 status
1813            }
1814            if {[llength $result] < 2} {
1815                break_softcontinue "The port '$portname' was not found" 1 status
1816            }
1817
1818            # Retrieve the port's URL.
1819            array unset portinfo
1820            array set portinfo [lindex $result 1]
1821            set porturl $portinfo(porturl)
1822        }
1823
1824        # Open the Portfile associated with this port.
1825        if {[catch {set mport [mportopen $porturl [array get options] \
1826                                         [array get merged_variations]]} \
1827                   result]} {
1828            ui_debug $::errorInfo
1829            break_softcontinue [concat "The URL '$porturl' could not be" \
1830                                       "opened: $result"] 1 status
1831        }
1832        array unset portinfo
1833        array set portinfo [mportinfo $mport]
1834        mportclose $mport
1835
1836        # Return the notes associated with this Portfile.
1837        if {[info exists portinfo(notes)]} {
1838            set portnotes $portinfo(notes)
1839        } else {
1840            set portnotes {}
1841        }
1842
1843        # Retrieve the port's name once more to ensure it has the proper case.
1844        set portname $portinfo(name)
1845
1846        # Display the notes.
1847        if {![macports::ui_isset ports_quiet]} {
1848            if {$portnotes ne {}} {
1849                puts "$portname has the following notes:"
1850                puts [wrap $portnotes 0 "  " 1]
1851            } else {
1852                puts "$portname has no notes."
1853            }
1854        }
1855    }
1856}
1857
1858
1859proc action_provides { action portlist opts } {
1860    # In this case, portname is going to be used for the filename... since
1861    # that is the first argument we expect... perhaps there is a better way
1862    # to do this?
1863    if { ![llength $portlist] } {
1864        ui_error "Please specify a filename to check which port provides that file."
1865        return 1
1866    }
1867    foreach filename $portlist {
1868        set file [file normalize $filename]
1869        if {[file exists $file]} {
1870            if {![file isdirectory $file]} {
1871                set port [registry::file_registered $file]
1872                if { $port != 0 } {
1873                    puts "$file is provided by: $port"
1874                } else {
1875                    puts "$file is not provided by a MacPorts port."
1876                }
1877            } else {
1878                puts "$file is a directory."
1879            }
1880        } else {
1881            puts "$file does not exist."
1882        }
1883    }
1884    registry::close_file_map
1885   
1886    return 0
1887}
1888
1889
1890proc action_activate { action portlist opts } {
1891    set status 0
1892    if {[require_portlist portlist]} {
1893        return 1
1894    }
1895    foreachport $portlist {
1896        if {![macports::global_option_isset ports_dryrun]} {
1897            if { [catch {portimage::activate $portname [composite_version $portversion [array get variations]] [array get options]} result] } {
1898                global errorInfo
1899                ui_debug "$errorInfo"
1900                break_softcontinue "port activate failed: $result" 1 status
1901            }
1902        } else {
1903            ui_msg "Skipping activate $portname (dry run)"
1904        }
1905    }
1906   
1907    return $status
1908}
1909
1910
1911proc action_deactivate { action portlist opts } {
1912    set status 0
1913    if {[require_portlist portlist]} {
1914        return 1
1915    }
1916    foreachport $portlist {
1917        if {![macports::global_option_isset ports_dryrun]} {
1918            if { [catch {portimage::deactivate $portname [composite_version $portversion [array get variations]] [array get options]} result] } {
1919                global errorInfo
1920                ui_debug "$errorInfo"
1921                break_softcontinue "port deactivate failed: $result" 1 status
1922            }
1923        } else {
1924            ui_msg "Skipping deactivate $portname (dry run)"
1925        }
1926    }
1927   
1928    return $status
1929}
1930
1931
1932proc action_select { action portlist opts } {
1933    ui_debug "action_select \[$portlist] \[$opts]..."
1934
1935    # Error out if no group is specified.
1936    if {[llength $portlist] < 1} {
1937        ui_error "port select \[--list|--set|--show] <group> \[<version>]"
1938        return 1
1939    }
1940    set group [lindex $portlist 0]
1941
1942    set commands [array names [array set {} $opts]]
1943    # If no command (--set, --show, --list) is specified *but* more than one
1944    # argument is specified, default to the set command.
1945    if {[llength $commands] < 1 && [llength $portlist] > 1} {
1946        set command set
1947        ui_debug [concat "Although no command was specified, more than " \
1948                         "one argument was specified.  Defaulting to the " \
1949                         "'set' command..."]
1950    # If no command (--set, --show, --list) is specified *and* less than two
1951    # argument are specified, default to the show command.
1952    } elseif {[llength $commands] < 1} {
1953        set command show
1954        ui_debug [concat "No command was specified. Defaulting to the " \
1955                         "'show' command..."]
1956    # Only allow one command to be specified at a time.
1957    } elseif {[llength $commands] > 1} {
1958        ui_error [concat "Multiple commands were specified. Only one " \
1959                         "command may be specified at a time."]
1960        return 1
1961    } else {
1962        set command [string map {ports_select_ ""} [lindex $commands 0]]
1963        ui_debug "The '$command' command was specified."
1964    }
1965
1966    switch -- $command {
1967        list {
1968            if {[llength $portlist] > 1} {
1969                ui_warn [concat "The 'list' command does not expect any " \
1970                                "arguments. Extra arguments will be ignored."]
1971            }
1972
1973            # On error mportselect returns with the code 'error'.
1974            if {[catch {mportselect $command $group} versions]} {
1975                ui_error "The 'list' command failed: $versions"
1976                return 1
1977            }
1978
1979            puts "Available Versions:"
1980            foreach v $versions {
1981                puts "\t$v"
1982            }
1983            return 0
1984        }
1985        set {
1986            if {[llength $portlist] < 2} {
1987                ui_error [concat "The 'set' command expects two " \
1988                                 "arguments: <group>, <version>"]
1989                return 1
1990            } elseif {[llength $portlist] > 2} {
1991                ui_warn [concat "The 'set' command only expects two " \
1992                                "arguments. Extra arguments will be " \
1993                                "ignored."]
1994            }
1995            set version [lindex $portlist 1]
1996
1997            puts -nonewline "Selecting '$version' for '$group' "
1998            if {[catch {mportselect $command $group $version} result]} {
1999                puts "failed: $result"
2000                return 1
2001            }
2002            puts "succeeded. '$version' is now active."
2003            return 0
2004        }
2005        show {
2006            if {[llength $portlist] > 1} {
2007                ui_warn [concat "The 'show' command does not expect any " \
2008                                "arguments. Extra arguments will be ignored."]
2009            }
2010
2011            if {[catch {mportselect $command $group} selected_version]} {
2012                ui_error "The 'show' command failed: $selected_version"
2013                return 1
2014            }
2015            puts [concat "The currently selected version for '$group' is " \
2016                         "'$selected_version'."]
2017            return 0
2018        }
2019        default {
2020            ui_error "An unknown command '$command' was specified."
2021            return 1
2022        }
2023    }
2024}
2025
2026
2027proc action_selfupdate { action portlist opts } {
2028    global global_options
2029    if { [catch {macports::selfupdate [array get global_options]} result ] } {
2030        global errorInfo
2031        ui_debug "$errorInfo"
2032        fatal "port selfupdate failed: $result"
2033    }
2034   
2035    return 0
2036}
2037
2038
2039proc action_upgrade { action portlist opts } {
2040    global global_variations
2041    if {[require_portlist portlist]} {
2042        return 1
2043    }
2044    # shared depscache for all ports in the list
2045    array set depscache {}
2046    foreachport $portlist {
2047        if {![registry::entry_exists_for_name $portname]} {
2048            ui_error "$portname is not installed"
2049            return 1
2050        }
2051        if {![info exists depscache(port:$portname)]} {
2052            # Global variations will have to be merged into the specified
2053            # variations, but perhaps after the installed variations are
2054            # merged. So we pass them into upgrade:
2055            macports::upgrade $portname "port:$portname" [array get global_variations] [array get variations] [array get options] depscache
2056        }
2057    }
2058
2059    return 0
2060}
2061
2062
2063proc action_version { action portlist opts } {
2064    puts "Version: [macports::version]"
2065    return 0
2066}
2067
2068
2069proc action_platform { action portlist opts } {
2070#   global os.platform os.major os.arch
2071    global tcl_platform
2072    set os_platform [string tolower $tcl_platform(os)]
2073    set os_version $tcl_platform(osVersion)
2074    set os_arch $tcl_platform(machine)
2075    if {$os_arch == "Power Macintosh"} { set os_arch "powerpc" }
2076    if {$os_arch == "i586" || $os_arch == "i686"} { set os_arch "i386" }
2077    set os_major [lindex [split $tcl_platform(osVersion) .] 0]
2078#   puts "Platform: ${os.platform} ${os.major} ${os.arch}"
2079    puts "Platform: ${os_platform} ${os_major} ${os_arch}"
2080    return 0
2081}
2082
2083
2084proc action_compact { action portlist opts } {
2085    set status 0
2086    if {[require_portlist portlist]} {
2087        return 1
2088    }
2089    foreachport $portlist {
2090        if { [catch {portimage::compact $portname [composite_version $portversion [array get variations]]} result] } {
2091            global errorInfo
2092            ui_debug "$errorInfo"
2093            break_softcontinue "port compact failed: $result" 1 status
2094        }
2095    }
2096
2097    return $status
2098}
2099
2100
2101proc action_uncompact { action portlist opts } {
2102    set status 0
2103    if {[require_portlist portlist]} {
2104        return 1
2105    }
2106    foreachport $portlist {
2107        if { [catch {portimage::uncompact $portname [composite_version $portversion [array get variations]]} result] } {
2108            global errorInfo
2109            ui_debug "$errorInfo"
2110            break_softcontinue "port uncompact failed: $result" 1 status
2111        }
2112    }
2113   
2114    return $status
2115}
2116
2117
2118proc action_dependents { action portlist opts } {
2119    if {[require_portlist portlist]} {
2120        return 1
2121    }
2122    set ilist {}
2123
2124    registry::open_dep_map
2125
2126    foreachport $portlist {
2127        set composite_version [composite_version $portversion [array get variations]]
2128        if { [catch {set ilist [registry::installed $portname $composite_version]} result] } {
2129            global errorInfo
2130            ui_debug "$errorInfo"
2131            break_softcontinue "$result" 1 status
2132        } else {
2133            # set portname again since the one we were passed may not have had the correct case
2134            set portname [lindex [lindex $ilist 0] 0]
2135        }
2136       
2137        set deplist [registry::list_dependents $portname]
2138        if { [llength $deplist] > 0 } {
2139            set dl [list]
2140            # Check the deps first
2141            foreach dep $deplist {
2142                set depport [lindex $dep 2]
2143                if {![macports::ui_isset ports_verbose]} {
2144                    ui_msg "$depport depends on $portname"
2145                } else {
2146                    ui_msg "$depport depends on $portname (by [lindex $dep 1]:)"
2147                }
2148            }
2149        } else {
2150            ui_msg "$portname has no dependents!"
2151        }
2152    }
2153    return 0
2154}
2155
2156
2157proc action_uninstall { action portlist opts } {
2158    set status 0
2159    if {[macports::global_option_isset port_uninstall_old]} {
2160        # if -u then uninstall all inactive ports
2161        # (union these to any other ports user has in the port list)
2162        set portlist [opUnion $portlist [get_inactive_ports]]
2163    } else {
2164        # Otherwise the user hopefully supplied a portlist, or we'll default to the existing directory
2165        if {[require_portlist portlist]} {
2166            return 1
2167        }
2168    }
2169
2170    foreachport $portlist {
2171        if { [catch {portuninstall::uninstall $portname [composite_version $portversion [array get variations]] [array get options]} result] } {
2172            global errorInfo
2173            ui_debug "$errorInfo"
2174            break_softcontinue "port uninstall failed: $result" 1 status
2175        }
2176    }
2177
2178    return 0
2179}
2180
2181
2182proc action_installed { action portlist opts } {
2183    global private_options
2184    set status 0
2185    set restrictedList 0
2186    set ilist {}
2187   
2188    if { [llength $portlist] || (![info exists private_options(ports_no_args)] || $private_options(ports_no_args) == "no")} {
2189        set restrictedList 1
2190        foreachport $portlist {
2191            set composite_version [composite_version $portversion [array get variations]]
2192            if { [catch {set ilist [concat $ilist [registry::installed $portname $composite_version]]} result] } {
2193                if {![string match "* not registered as installed." $result]} {
2194                    global errorInfo
2195                    ui_debug "$errorInfo"
2196                    break_softcontinue "port installed failed: $result" 1 status
2197                }
2198            }
2199        }
2200    } else {
2201        if { [catch {set ilist [registry::installed]} result] } {
2202            if {$result != "Registry error: No ports registered as installed."} {
2203                global errorInfo
2204                ui_debug "$errorInfo"
2205                ui_error "port installed failed: $result"
2206                set status 1
2207            }
2208        }
2209    }
2210    if { [llength $ilist] > 0 } {
2211        if {![macports::ui_isset ports_quiet]} {
2212            puts "The following ports are currently installed:"
2213        }
2214        foreach i [portlist_sortint $ilist] {
2215            set iname [lindex $i 0]
2216            set iversion [lindex $i 1]
2217            set irevision [lindex $i 2]
2218            set ivariants [lindex $i 3]
2219            set iactive [lindex $i 4]
2220            if { $iactive == 0 } {
2221                puts "  $iname @${iversion}_${irevision}${ivariants}"
2222            } elseif { $iactive == 1 } {
2223                puts "  $iname @${iversion}_${irevision}${ivariants} (active)"
2224            }
2225        }
2226    } elseif { $restrictedList } {
2227        puts "None of the specified ports are installed."
2228    } else {
2229        puts "No ports are installed."
2230    }
2231   
2232    return $status
2233}
2234
2235
2236proc action_outdated { action portlist opts } {
2237    global macports::registry.installtype private_options
2238    set is_image_mode [expr 0 == [string compare "image" ${macports::registry.installtype}]]
2239
2240    set status 0
2241
2242    # If port names were supplied, limit ourselves to those ports, else check all installed ports
2243    set ilist {}
2244    set restrictedList 0
2245    if { [llength $portlist] || (![info exists private_options(ports_no_args)] || $private_options(ports_no_args) == "no")} {
2246        set restrictedList 1
2247        foreach portspec $portlist {
2248            array set port $portspec
2249            set portname $port(name)
2250            set composite_version [composite_version $port(version) $port(variants)]
2251            if { [catch {set ilist [concat $ilist [registry::installed $portname $composite_version]]} result] } {
2252                if {![string match "* not registered as installed." $result]} {
2253                    global errorInfo
2254                    ui_debug "$errorInfo"
2255                    break_softcontinue "port outdated failed: $result" 1 status
2256                }
2257            }
2258        }
2259    } else {
2260        if { [catch {set ilist [registry::installed]} result] } {
2261            if {$result != "Registry error: No ports registered as installed."} {
2262                global errorInfo
2263                ui_debug "$errorInfo"
2264                ui_error "port installed failed: $result"
2265                set status 1
2266            }
2267        }
2268    }
2269
2270    set num_outdated 0
2271    if { [llength $ilist] > 0 } {   
2272        foreach i $ilist { 
2273       
2274            # Get information about the installed port
2275            set portname [lindex $i 0]
2276            set installed_version [lindex $i 1]
2277            set installed_revision [lindex $i 2]
2278            set installed_compound "${installed_version}_${installed_revision}"
2279
2280            set is_active [lindex $i 4]
2281            if { $is_active == 0 && $is_image_mode } {
2282                continue
2283            }
2284            set installed_epoch [lindex $i 5]
2285
2286            # Get info about the port from the index
2287            if {[catch {set res [mportlookup $portname]} result]} {
2288                global errorInfo
2289                ui_debug "$errorInfo"
2290                break_softcontinue "search for portname $portname failed: $result" 1 status
2291            }
2292            if {[llength $res] < 2} {
2293                if {[macports::ui_isset ports_debug]} {
2294                    puts "$portname ($installed_compound is installed; the port was not found in the port index)"
2295                }
2296                continue
2297            }
2298            array unset portinfo
2299            array set portinfo [lindex $res 1]
2300           
2301            # Get information about latest available version and revision
2302            set latest_version $portinfo(version)
2303            set latest_revision 0
2304            if {[info exists portinfo(revision)] && $portinfo(revision) > 0} { 
2305                set latest_revision $portinfo(revision)
2306            }
2307            set latest_compound "${latest_version}_${latest_revision}"
2308            set latest_epoch 0
2309            if {[info exists portinfo(epoch)]} { 
2310                set latest_epoch $portinfo(epoch)
2311            }
2312           
2313            # Compare versions, first checking epoch, then version, then revision
2314            set comp_result [expr $installed_epoch - $latest_epoch]
2315            if { $comp_result == 0 } {
2316                set comp_result [rpm-vercomp $installed_version $latest_version]
2317                if { $comp_result == 0 } {
2318                    set comp_result [rpm-vercomp $installed_revision $latest_revision]
2319                }
2320            }
2321           
2322            # Report outdated (or, for verbose, predated) versions
2323            if { $comp_result != 0 } {
2324                           
2325                # Form a relation between the versions
2326                set flag ""
2327                if { $comp_result > 0 } {
2328                    set relation ">"
2329                    set flag "!"
2330                } else {
2331                    set relation "<"
2332                }
2333               
2334                # Emit information
2335                if {$comp_result < 0 || [macports::ui_isset ports_verbose]} {
2336               
2337                    if { $num_outdated == 0 && ![macports::ui_isset ports_quiet]} {
2338                        puts "The following installed ports are outdated:"
2339                    }
2340                    incr num_outdated
2341
2342                    puts [format "%-30s %-24s %1s" $portname "$installed_compound $relation $latest_compound" $flag]
2343                }
2344               
2345            }
2346        }
2347       
2348        if { $num_outdated == 0 && ![macports::ui_isset ports_quiet]} {
2349            puts "No installed ports are outdated."
2350        }
2351    } elseif { $restrictedList } {
2352        if {![macports::ui_isset ports_quiet]} {
2353            puts "None of the specified ports are outdated."
2354        }
2355    } else {
2356        if {![macports::ui_isset ports_quiet]} {
2357            puts "No ports are installed."
2358        }
2359    }
2360   
2361    return $status
2362}
2363
2364
2365proc action_contents { action portlist opts } {
2366    set status 0
2367    if {[require_portlist portlist]} {
2368        return 1
2369    }
2370    foreachport $portlist {
2371        if { ![catch {set ilist [registry::installed $portname]} result] } {
2372            # set portname again since the one we were passed may not have had the correct case
2373            set portname [lindex [lindex $ilist 0] 0]
2374        }
2375        set files [registry::port_registered $portname]
2376        if { $files != 0 } {
2377            if { [llength $files] > 0 } {
2378                if {![macports::ui_isset ports_quiet]} {
2379                    puts "Port $portname contains:"
2380                }
2381                foreach file $files {
2382                    puts "  $file"
2383                }
2384            } else {
2385                if {![macports::ui_isset ports_quiet]} {
2386                    puts "Port $portname does not contain any file or is not active."
2387                }
2388            }
2389        } else {
2390            if {![macports::ui_isset ports_quiet]} {
2391                puts "Port $portname is not installed."
2392            }
2393        }
2394    }
2395    registry::close_file_map
2396
2397    return $status
2398}
2399
2400proc action_variants { action portlist opts } {
2401    global global_variations
2402    set status 0
2403    if {[require_portlist portlist]} {
2404        return 1
2405    }
2406    foreachport $portlist {
2407        if {$porturl eq ""} {
2408            # look up port
2409            if {[catch {mportlookup $portname} result]} {
2410                global errorInfo
2411                ui_debug "$errorInfo"
2412                break_softcontinue "lookup of portname $portname failed: $result" 1 status
2413            }
2414            if {[llength $result] < 2} {
2415                break_softcontinue "Port $portname not found" 1 status
2416            }
2417
2418            array unset portinfo
2419            array set portinfo [lindex $result 1]
2420
2421            set porturl $portinfo(porturl)
2422            set portdir $portinfo(portdir)
2423        }
2424
2425        if {!([info exists options(ports_variants_index)] && $options(ports_variants_index) eq "yes")} {
2426            if {[catch {set mport [mportopen $porturl [array get options] [array get variations]]} result]} {
2427                ui_debug "$::errorInfo"
2428                break_softcontinue "Unable to open port: $result" 1 status
2429            }
2430            array unset portinfo
2431            array set portinfo [mportinfo $mport]
2432            mportclose $mport
2433            if {[info exists portdir]} {
2434                set portinfo(portdir) $portdir
2435            }
2436        } elseif {![info exists portinfo]} {
2437            ui_warn "port variants --index does not work with 'current' pseudo-port"
2438            continue
2439        }
2440
2441        # set portname again since the one we were passed may not have had the correct case
2442        set portname $portinfo(name)
2443
2444        # if this fails the port doesn't have any variants
2445        if {![info exists portinfo(variants)]} {
2446            if {![macports::ui_isset ports_quiet]} {
2447                puts "$portname has no variants"
2448            }
2449        } else {
2450            array unset vinfo
2451            # Use the new format if it exists.
2452            if {[info exists portinfo(vinfo)]} {
2453                array set vinfo $portinfo(vinfo)
2454            # Otherwise fall back to the old format.
2455            } elseif {[info exists portinfo(variant_desc)]} {
2456                array set vdescriptions $portinfo(variant_desc)
2457            }
2458
2459            # print out all the variants
2460            if {![macports::ui_isset ports_quiet]} {
2461                puts "$portname has the variants:"
2462            }
2463            foreach v [lsort $portinfo(variants)] {
2464                unset -nocomplain vconflicts vdescription vrequires
2465                # Retrieve variants' information from the new format.
2466                if {[info exists vinfo]} {
2467                    array unset variant
2468                    array set variant $vinfo($v)
2469
2470                    # Retrieve conflicts, description, is_default, and
2471                    # vrequires.
2472                    if {[info exists variant(conflicts)]} {
2473                        set vconflicts $variant(conflicts)
2474                    }
2475                    if {[info exists variant(description)]} {
2476                        set vdescription $variant(description)
2477                    }
2478
2479                    # XXX Keep these varmodifiers in sync with action_info, or create a wrapper for it
2480                    if {[info exists variations($v)]} {
2481                        set varmodifier "  $variations($v)"
2482                    } elseif {[info exists global_variations($v)]} {
2483                        # selected by variants.conf, prefixed with (+)/(-)
2484                        set varmodifier "($global_variations($v))"
2485                    } elseif {[info exists variant(is_default)]} {
2486                        set varmodifier "\[+]"
2487                    } else {
2488                        set varmodifier "   "
2489                    }
2490                    if {[info exists variant(requires)]} {
2491                        set vrequires $variant(requires)
2492                    }
2493                # Retrieve variants' information from the old format,
2494                # which only consists of the description.
2495                } elseif {[info exists vdescriptions($v)]} {
2496                    set vdescription $vdescriptions($v)
2497                }
2498
2499                if {[info exists vdescription]} {
2500                    puts [wraplabel "$varmodifier$v" [string trim $vdescription] 0 [string repeat " " [expr 5 + [string length $v]]]]
2501                } else {
2502                    puts "$varmodifier$v"
2503                }
2504                if {[info exists vconflicts]} {
2505                    puts "     * conflicts with [string trim $vconflicts]"
2506                }
2507                if {[info exists vrequires]} {
2508                    puts "     * requires [string trim $vrequires]"
2509                }
2510            }
2511        }
2512    }
2513
2514    return $status
2515}
2516
2517
2518proc action_search { action portlist opts } {
2519    global private_options global_options
2520    set status 0
2521    if {![llength $portlist] && [info exists private_options(ports_no_args)] && $private_options(ports_no_args) == "yes"} {
2522        ui_error "You must specify a search pattern"
2523        return 1
2524    }
2525
2526    # Copy global options as we are going to modify the array
2527    array set options [array get global_options]
2528
2529    if {[info exists options(ports_search_depends)] && $options(ports_search_depends) == "yes"} {
2530        array unset options ports_search_depends
2531        set options(ports_search_depends_fetch) yes
2532        set options(ports_search_depends_extract) yes
2533        set options(ports_search_depends_build) yes
2534        set options(ports_search_depends_lib) yes
2535        set options(ports_search_depends_run) yes
2536    }
2537
2538    # Array to hold given filters
2539    array set filters {}
2540    # Default matchstyle
2541    set filter_matchstyle "none"
2542    set filter_case no
2543    foreach { option } [array names options ports_search_*] {
2544        set opt [string range $option 13 end]
2545
2546        if { $options($option) != "yes" } {
2547            continue
2548        }
2549        switch -- $opt {
2550            exact -
2551            glob -
2552            regex {
2553                set filter_matchstyle $opt
2554                continue
2555            }
2556            case-sensitive {
2557                set filter_case yes
2558                continue
2559            }
2560            line {
2561                continue
2562            }
2563        }
2564
2565        set filters($opt) "yes"
2566    }
2567    # Set default search filter if none was given
2568    if { [array size filters] == 0 } {
2569        set filters(name) "yes"
2570        set filters(description) "yes"
2571    }
2572
2573    set separator ""
2574    foreach portname $portlist {
2575        puts -nonewline $separator
2576
2577        set searchstring $portname
2578        set matchstyle $filter_matchstyle
2579        if {$matchstyle == "none"} {
2580            # Guess if the given string was a glob expression, if not do a substring search
2581            if {[string first "*" $portname] == -1 && [string first "?" $portname] == -1} {
2582                set searchstring "*$portname*"
2583            }
2584            set matchstyle glob
2585        }
2586
2587        set res {}
2588        set portfound 0
2589        foreach { opt } [array get filters] {
2590            # Map from friendly name
2591            set opt [map_friendly_field_names $opt]
2592
2593            if {[catch {eval set matches \[mportsearch \$searchstring $filter_case $matchstyle $opt\]} result]} {
2594                global errorInfo
2595                ui_debug "$errorInfo"
2596                break_softcontinue "search for name $portname failed: $result" 1 status
2597            }
2598
2599            set tmp {}
2600            foreach {name info} $matches {
2601                add_to_portlist tmp [concat [list name $name] $info]
2602            }
2603            set res [opUnion $res $tmp]
2604        }
2605        set res [portlist_sort $res]
2606
2607        set joiner ""
2608        foreach info $res {
2609            array unset portinfo
2610            array set portinfo $info
2611
2612            # XXX is this the right place to verify an entry?
2613            if {![info exists portinfo(name)]} {
2614                puts stderr "Invalid port entry, missing portname"
2615                continue
2616            }
2617            if {![info exists portinfo(description)]} {
2618                puts stderr "Invalid port entry for $portinfo(name), missing description"
2619                continue
2620            }
2621            if {![info exists portinfo(version)]} {
2622                puts stderr "Invalid port entry for $portinfo(name), missing version"
2623                continue
2624            }
2625
2626            if {[macports::ui_isset ports_quiet]} {
2627                puts $portinfo(name)
2628            } else {
2629                if {[info exists options(ports_search_line)]
2630                        && $options(ports_search_line) == "yes"} {
2631                    puts "$portinfo(name)\t$portinfo(version)\t$portinfo(categories)\t$portinfo(description)"
2632                } else {
2633                    puts -nonewline $joiner
2634
2635                    puts -nonewline "$portinfo(name) @$portinfo(version)"
2636                    if {[info exists portinfo(categories)]} {
2637                        puts -nonewline " ([join $portinfo(categories) ", "])"
2638                    }
2639                    puts ""
2640                    puts [wrap [join $portinfo(description)] 0 [string repeat " " 4]]
2641                }
2642            }
2643
2644            set joiner "\n"
2645            set portfound 1
2646        }
2647        if { !$portfound } {
2648            if {![macports::ui_isset ports_quiet]} {
2649                ui_msg "No match for $portname found"
2650            }
2651        } elseif {[llength $res] > 1} {
2652            if {(![info exists global_options(ports_search_line)]
2653                    || $global_options(ports_search_line) != "yes")
2654                    && ![macports::ui_isset ports_quiet]} {
2655                ui_msg "\nFound [llength $res] ports."
2656            }
2657        }
2658
2659        set separator "--\n"
2660    }
2661
2662    array unset options
2663    array unset filters
2664
2665    return $status
2666}
2667
2668
2669proc action_list { action portlist opts } {
2670    global private_options
2671    set status 0
2672   
2673    # Default to list all ports if no portnames are supplied
2674    if { ![llength $portlist] && [info exists private_options(ports_no_args)] && $private_options(ports_no_args) == "yes"} {
2675        add_to_portlist portlist [list name "-all-"]
2676    }
2677   
2678    foreachport $portlist {
2679        if {$portname == "-all-"} {
2680            set search_string ".+"
2681        } else {
2682            set search_string [regex_pat_sanitize $portname]
2683        }
2684       
2685        if {[catch {set res [mportsearch ^$search_string\$ no]} result]} {
2686            global errorInfo
2687            ui_debug "$errorInfo"
2688            break_softcontinue "search for portname $search_string failed: $result" 1 status
2689        }
2690
2691        foreach {name array} $res {
2692            array unset portinfo
2693            array set portinfo $array
2694            set outdir ""
2695            if {[info exists portinfo(portdir)]} {
2696                set outdir $portinfo(portdir)
2697            }
2698            puts [format "%-30s @%-14s %s" $portinfo(name) $portinfo(version) $outdir]
2699        }
2700    }
2701   
2702    return $status
2703}
2704
2705
2706proc action_echo { action portlist opts } {
2707    # Simply echo back the port specs given to this command
2708    foreachport $portlist {
2709        set opts {}
2710        foreach { key value } [array get options] {
2711            lappend opts "$key=$value"
2712        }
2713       
2714        set composite_version [composite_version $portversion [array get variations] 1]
2715        if { $composite_version != "" } {
2716            set ver_field "@$composite_version"
2717        } else {
2718            set ver_field ""
2719        }
2720        puts [format "%-30s %s %s" $portname $ver_field  [join $opts " "]]
2721    }
2722   
2723    return 0
2724}
2725
2726
2727proc action_portcmds { action portlist opts } {
2728    # Operations on the port's directory and Portfile
2729    global env boot_env
2730    global current_portdir
2731
2732    array set local_options $opts
2733   
2734    set status 0
2735    if {[require_portlist portlist]} {
2736        return 1
2737    }
2738    foreachport $portlist {
2739        # If we have a url, use that, since it's most specific, otherwise try to map the portname to a url
2740        if {$porturl == ""} {
2741       
2742            # Verify the portname, getting portinfo to map to a porturl
2743            if {[catch {set res [mportlookup $portname]} result]} {
2744                global errorInfo
2745                ui_debug "$errorInfo"
2746                break_softcontinue "lookup of portname $portname failed: $result" 1 status
2747            }
2748            if {[llength $res] < 2} {
2749                break_softcontinue "Port $portname not found" 1 status
2750            }
2751            array set portinfo [lindex $res 1]
2752            set porturl $portinfo(porturl)
2753        }
2754       
2755       
2756        # Calculate portdir, porturl, and portfile from initial porturl
2757        set portdir [file normalize [macports::getportdir $porturl]]
2758        set porturl "file://${portdir}";    # Rebuild url so it's fully qualified
2759        set portfile "${portdir}/Portfile"
2760       
2761        # Now execute the specific action
2762        if {[file readable $portfile]} {
2763            switch -- $action {
2764                cat {
2765                    # Copy the portfile to standard output
2766                    set f [open $portfile RDONLY]
2767                    while { ![eof $f] } {
2768                        puts -nonewline [read $f 4096]
2769                    }
2770                    close $f
2771                }
2772               
2773                ed - edit {
2774                    # Edit the port's portfile with the user's editor
2775                   
2776                    # Restore our entire environment from start time.
2777                    # We need it to evaluate the editor, and the editor
2778                    # may want stuff from it as well, like TERM.
2779                    array unset env_save; array set env_save [array get env]
2780                    array unset env *; unsetenv *; array set env [array get boot_env]
2781                   
2782                    # Find an editor to edit the portfile
2783                    set editor ""
2784                    if {[info exists local_options(ports_edit_editor)]} {
2785                        set editor [join $local_options(ports_edit_editor)]
2786                    } elseif {[info exists local_options(ports_ed_editor)]} {
2787                        set editor [join $local_options(ports_ed_editor)]
2788                    } else {
2789                        foreach ed { VISUAL EDITOR } {
2790                            if {[info exists env($ed)]} {
2791                                set editor $env($ed)
2792                                break
2793                            }
2794                        }
2795                    }
2796                   
2797                    # Invoke the editor, with a reasonable canned default.
2798                    if { $editor == "" } { set editor "/usr/bin/vi" }
2799                    if {[catch {eval exec >/dev/stdout </dev/stdin $editor $portfile} result]} {
2800                        global errorInfo
2801                        ui_debug "$errorInfo"
2802                        break_softcontinue "unable to invoke editor $editor: $result" 1 status
2803                    }
2804                   
2805                    # Restore internal MacPorts environment
2806                    array unset env *; unsetenv *; array set env [array get env_save]
2807                }
2808
2809                dir {
2810                    # output the path to the port's directory
2811                    puts $portdir
2812                }
2813
2814                work {
2815                    # output the path to the port's work directory
2816                    set workpath [macports::getportworkpath_from_portdir $portdir]
2817                    if {[file exists $workpath]} {
2818                        puts $workpath
2819                    }
2820                }
2821
2822                cd {
2823                    # Change to the port's directory, making it the default
2824                    # port for any future commands
2825                    set current_portdir $portdir
2826                }
2827
2828                url {
2829                    # output the url of the port's directory, suitable to feed back in later as a port descriptor
2830                    puts $porturl
2831                }
2832
2833                file {
2834                    # output the path to the port's portfile
2835                    puts $portfile
2836                }
2837
2838                gohome {
2839                    set homepage ""
2840
2841                    # Get the homepage as read from PortIndex
2842                    if {[info exists portinfo(homepage)]} {
2843                        set homepage $portinfo(homepage)
2844                    }
2845
2846                    # If not available, get the homepage for the port by opening the Portfile
2847                    if {$homepage == "" && ![catch {set ctx [mportopen $porturl]} result]} {
2848                        array set portinfo [mportinfo $ctx]
2849                        if {[info exists portinfo(homepage)]} {
2850                            set homepage $portinfo(homepage)
2851                        }
2852                        mportclose $ctx
2853                    }
2854
2855                    # Try to open a browser to the homepage for the given port
2856                    if { $homepage != "" } {
2857                        system "${macports::autoconf::open_path} '$homepage'"
2858                    } else {
2859                        ui_error [format "No homepage for %s" $portname]
2860                    }
2861                }
2862            }
2863        } else {
2864            break_softcontinue "Could not read $portfile" 1 status
2865        }
2866    }
2867   
2868    return $status
2869}
2870
2871
2872proc action_sync { action portlist opts } {
2873    global global_options
2874
2875    set status 0
2876    if {[catch {mportsync [array get global_options]} result]} {
2877        global errorInfo
2878        ui_debug "$errorInfo"
2879        ui_msg "port sync failed: $result"
2880        set status 1
2881    }
2882   
2883    return $status
2884}
2885
2886
2887proc action_target { action portlist opts } {
2888    global global_variations
2889    set status 0
2890    if {[require_portlist portlist]} {
2891        return 1
2892    }
2893    foreachport $portlist {
2894        set target $action
2895
2896        # If we have a url, use that, since it's most specific
2897        # otherwise try to map the portname to a url
2898        if {$porturl == ""} {
2899            # Verify the portname, getting portinfo to map to a porturl
2900            if {[catch {set res [mportlookup $portname]} result]} {
2901                global errorInfo
2902                ui_debug "$errorInfo"
2903                break_softcontinue "lookup of portname $portname failed: $result" 1 status
2904            }
2905            if {[llength $res] < 2} {
2906                # don't error for ports that are installed but not in the tree
2907                if {[registry::entry_exists_for_name $portname]} {
2908                    ui_warn "Skipping $portname (not in the ports tree)"
2909                    continue
2910                } else {
2911                    break_softcontinue "Port $portname not found" 1 status
2912                }
2913            }
2914            array unset portinfo
2915            array set portinfo [lindex $res 1]
2916            set porturl $portinfo(porturl)
2917        }
2918       
2919        # Add any global_variations to the variations
2920        # specified for the port
2921        foreach { variation value } [array get global_variations] {
2922            if { ![info exists variations($variation)] } {
2923                set variations($variation) $value
2924            }
2925        }
2926
2927        # If version was specified, save it as a version glob for use
2928        # in port actions (e.g. clean).
2929        if {[string length $portversion]} {
2930            set options(ports_version_glob) $portversion
2931        }
2932        if {[catch {set workername [mportopen $porturl [array get options] [array get variations]]} result]} {
2933            global errorInfo
2934            ui_debug "$errorInfo"
2935            break_softcontinue "Unable to open port: $result" 1 status
2936        }
2937        if {[catch {set result [mportexec $workername $target]} result]} {
2938            global errorInfo
2939            mportclose $workername
2940            ui_debug "$errorInfo"
2941            break_softcontinue "Unable to execute port: $result" 1 status
2942        }
2943
2944        mportclose $workername
2945       
2946        # Process any error that wasn't thrown and handled already
2947        if {$result} {
2948            break_softcontinue "Status $result encountered during processing." 1 status
2949        }
2950    }
2951   
2952    return $status
2953}
2954
2955
2956proc action_exit { action portlist opts } {
2957    # Return a semaphore telling the main loop to quit
2958    return -999
2959}
2960
2961
2962##########################################
2963# Command Parsing
2964##########################################
2965proc moreargs {} {
2966    global cmd_argn cmd_argc
2967    return [expr {$cmd_argn < $cmd_argc}]
2968}
2969
2970
2971proc lookahead {} {
2972    global cmd_argn cmd_argc cmd_argv
2973    if {$cmd_argn < $cmd_argc} {
2974        return [lindex $cmd_argv $cmd_argn]
2975    } else {
2976        return _EOF_
2977    }
2978}
2979
2980
2981proc advance {} {
2982    global cmd_argn
2983    incr cmd_argn
2984}
2985
2986
2987proc match s {
2988    if {[lookahead] == $s} {
2989        advance
2990        return 1
2991    }
2992    return 0
2993}
2994
2995# action_array specifies which action to run on the given command
2996# and if the action wants an expanded portlist.
2997# The value is a list of the form {action expand},
2998# where action is a string and expand a value:
2999#   0 none        Does not expect any text argument
3000#   1 strings     Expects some strings as text argument
3001#   2 ports       Wants an expanded list of ports as text argument
3002# Use action_args_const to translate them
3003global action_array
3004proc action_args_const {arg} {
3005    switch -- $arg {
3006        none {
3007            return 0
3008        }
3009        strings {
3010            return 1
3011        }
3012        default -
3013        ports {
3014            return 2
3015        }
3016    }
3017}
3018array set action_array [list \
3019    usage       [list action_usage          [action_args_const strings]] \
3020    help        [list action_help           [action_args_const strings]] \
3021    \
3022    echo        [list action_echo           [action_args_const ports]] \
3023    \
3024    info        [list action_info           [action_args_const ports]] \
3025    location    [list action_location       [action_args_const ports]] \
3026    notes       [list action_notes          [action_args_const ports]] \
3027    provides    [list action_provides       [action_args_const strings]] \
3028    log         [list action_log            [action_args_const ports]] \
3029    \
3030    activate    [list action_activate       [action_args_const ports]] \
3031    deactivate  [list action_deactivate     [action_args_const ports]] \
3032    \
3033    select      [list action_select         [action_args_const strings]] \
3034    \
3035    sync        [list action_sync           [action_args_const none]] \
3036    selfupdate  [list action_selfupdate     [action_args_const none]] \
3037    \
3038    upgrade     [list action_upgrade        [action_args_const ports]] \
3039    \
3040    version     [list action_version        [action_args_const none]] \
3041    platform    [list action_platform       [action_args_const none]] \
3042    compact     [list action_compact        [action_args_const ports]] \
3043    uncompact   [list action_uncompact      [action_args_const ports]] \
3044    \
3045    uninstall   [list action_uninstall      [action_args_const ports]] \
3046    \
3047    installed   [list action_installed      [action_args_const ports]] \
3048    outdated    [list action_outdated       [action_args_const ports]] \
3049    contents    [list action_contents       [action_args_const ports]] \
3050    dependents  [list action_dependents     [action_args_const ports]] \
3051    deps        [list action_info           [action_args_const ports]] \
3052    variants    [list action_variants       [action_args_const ports]] \
3053    \
3054    search      [list action_search         [action_args_const strings]] \
3055    list        [list action_list           [action_args_const ports]] \
3056    \
3057    ed          [list action_portcmds       [action_args_const ports]] \
3058    edit        [list action_portcmds       [action_args_const ports]] \
3059    cat         [list action_portcmds       [action_args_const ports]] \
3060    dir         [list action_portcmds       [action_args_const ports]] \
3061    work        [list action_portcmds       [action_args_const ports]] \
3062    cd          [list action_portcmds       [action_args_const ports]] \
3063    url         [list action_portcmds       [action_args_const ports]] \
3064    file        [list action_portcmds       [action_args_const ports]] \
3065    gohome      [list action_portcmds       [action_args_const ports]] \
3066    \
3067    fetch       [list action_target         [action_args_const ports]] \
3068    checksum    [list action_target         [action_args_const ports]] \
3069    extract     [list action_target         [action_args_const ports]] \
3070    patch       [list action_target         [action_args_const ports]] \
3071    configure   [list action_target         [action_args_const ports]] \
3072    build       [list action_target         [action_args_const ports]] \
3073    destroot    [list action_target         [action_args_const ports]] \
3074    install     [list action_target         [action_args_const ports]] \
3075    clean       [list action_target         [action_args_const ports]] \
3076    test        [list action_target         [action_args_const ports]] \
3077    lint        [list action_target         [action_args_const ports]] \
3078    submit      [list action_target         [action_args_const ports]] \
3079    trace       [list action_target         [action_args_const ports]] \
3080    livecheck   [list action_target         [action_args_const ports]] \
3081    distcheck   [list action_target         [action_args_const ports]] \
3082    mirror      [list action_target         [action_args_const ports]] \
3083    load        [list action_target         [action_args_const ports]] \
3084    unload      [list action_target         [action_args_const ports]] \
3085    distfiles   [list action_target         [action_args_const ports]] \
3086    \
3087    archive     [list action_target         [action_args_const ports]] \
3088    unarchive   [list action_target         [action_args_const ports]] \
3089    dmg         [list action_target         [action_args_const ports]] \
3090    mdmg        [list action_target         [action_args_const ports]] \
3091    dpkg        [list action_target         [action_args_const ports]] \
3092    mpkg        [list action_target         [action_args_const ports]] \
3093    pkg         [list action_target         [action_args_const ports]] \
3094    portpkg     [list action_target         [action_args_const ports]] \
3095    rpm         [list action_target         [action_args_const ports]] \
3096    srpm        [list action_target         [action_args_const ports]] \
3097    \
3098    quit        [list action_exit           [action_args_const none]] \
3099    exit        [list action_exit           [action_args_const none]] \
3100]
3101
3102proc find_action_proc { action } {
3103    global action_array
3104   
3105    set action_proc ""
3106    if { [info exists action_array($action)] } {
3107        set action_proc [lindex $action_array($action) 0]
3108    }
3109   
3110    return $action_proc
3111}
3112
3113# Returns whether an action expects text arguments at all,
3114# expects text arguments or wants an expanded list of ports
3115# Return value:
3116#   0 none        Does not expect any text argument
3117#   1 strings     Expects some strings as text argument
3118#   2 ports       Wants an expanded list of ports as text argument
3119# Use action_args_const to translate them
3120proc action_needs_portlist { action } {
3121    global action_array
3122
3123    set ret 0
3124    if {[info exists action_array($action)]} {
3125        set ret [lindex $action_array($action) 1]
3126    }
3127
3128    return $ret
3129}
3130
3131# cmd_opts_array specifies which arguments the commands accept
3132# Commands not listed here do not accept any arguments
3133# Syntax if {option argn}
3134# Where option is the name of the option and argn specifies how many arguments
3135# this argument takes
3136global cmd_opts_array
3137array set cmd_opts_array {
3138    edit        {{editor 1}}
3139    ed          {{editor 1}}
3140    info        {category categories depends_fetch depends_extract
3141                 depends_build depends_lib depends_run
3142                 depends description epoch fullname heading homepage index license
3143                 line long_description
3144                 maintainer maintainers name platform platforms portdir pretty
3145                 revision variant variants version}
3146    search      {case-sensitive category categories depends_fetch
3147                 depends_extract depends_build depends_lib depends_run
3148                 depends description epoch exact glob homepage line
3149                 long_description maintainer maintainers name platform
3150                 platforms portdir regex revision variant variants version}
3151    selfupdate  {nosync}
3152    uninstall   {follow-dependents}
3153    variants    {index}
3154    clean       {all archive dist work}
3155    mirror      {new}
3156    lint        {nitpick}
3157    select      {list set show}
3158}
3159
3160global cmd_implied_options
3161array set cmd_implied_options {
3162    deps   {ports_info_fullname yes ports_info_depends yes ports_info_pretty yes}
3163}
3164                                 
3165
3166##
3167# Checks whether the given option is valid
3168#
3169# œparam action for which action
3170# @param option the option to check
3171# @param upoptargc reference to upvar for storing the number of arguments for
3172#                  this option
3173proc cmd_option_exists { action option {upoptargc ""}} {
3174    global cmd_opts_array
3175    upvar 1 $upoptargc optargc
3176
3177    # This could be so easy with lsearch -index,
3178    # but that's only available as of Tcl 8.5
3179
3180    if {![info exists cmd_opts_array($action)]} {
3181        return 0
3182    }
3183
3184    foreach item $cmd_opts_array($action) {
3185        if {[llength $item] == 1} {
3186            set name $item
3187            set argc 0
3188        } else {
3189            set name [lindex $item 0]
3190            set argc [lindex $item 1]
3191        }
3192
3193        if {$name == $option} {
3194            set optargc $argc
3195            return 1
3196        }
3197    }
3198
3199    return 0
3200}
3201
3202# Parse global options
3203#
3204# Note that this is called several times:
3205#   (1) Initially, to parse options that will be constant across all commands
3206#       (options that come prior to any command, frozen into global_options_base)
3207#   (2) Following each command (to parse options that will be unique to that command
3208#       (the global_options array is reset to global_options_base prior to each command)
3209#
3210proc parse_options { action ui_options_name global_options_name } {
3211    upvar $ui_options_name ui_options
3212    upvar $global_options_name global_options
3213    global cmdname cmd_opts_array
3214   
3215    while {[moreargs]} {
3216        set arg [lookahead]
3217       
3218        if {[string index $arg 0] != "-"} {
3219            break
3220        } elseif {[string index $arg 1] == "-"} {
3221            # Process long arguments
3222            switch -- $arg {
3223                -- { # This is the options terminator; do no further option processing
3224                    advance; break
3225                }
3226                default {
3227                    set key [string range $arg 2 end]
3228                    set kargc 0
3229                    if {![cmd_option_exists $action $key kargc]} {
3230                        return -code error "${action} does not accept --${key}"
3231                    }
3232                    if {$kargc == 0} {
3233                        set global_options(ports_${action}_${key}) yes
3234                    } else {
3235                        set args {}
3236                        while {[moreargs] && $kargc > 0} {
3237                            advance
3238                            lappend args [lookahead]
3239                            set kargc [expr $kargc - 1]
3240                        }
3241                        if {$kargc > 0} {
3242                            return -code error "--${key} expects [expr $kargc + [llength $args]] parameters!"
3243                        }
3244                        set global_options(ports_${action}_${key}) $args
3245                    }
3246                }
3247            }
3248        } else {
3249            # Process short arg(s)
3250            set opts [string range $arg 1 end]
3251            foreach c [split $opts {}] {
3252                switch -- $c {
3253                    v {
3254                        set ui_options(ports_verbose) yes
3255                    }
3256                    d {
3257                        set ui_options(ports_debug) yes
3258                        # debug implies verbose
3259                        set ui_options(ports_verbose) yes
3260                    }
3261                    q {
3262                        set ui_options(ports_quiet) yes
3263                        set ui_options(ports_verbose) no
3264                        set ui_options(ports_debug) no
3265                    }
3266                    p {
3267                        # Ignore errors while processing within a command
3268                        set ui_options(ports_processall) yes
3269                    }
3270                    x {
3271                        # Exit with error from any command while in batch/interactive mode
3272                        set ui_options(ports_exit) yes
3273                    }
3274
3275                    f {
3276                        set global_options(ports_force) yes
3277                    }
3278                    o {
3279                        set global_options(ports_ignore_older) yes
3280                    }
3281                    n {
3282                        set global_options(ports_nodeps) yes
3283                    }
3284                    u {
3285                        set global_options(port_uninstall_old) yes
3286                    }
3287                    R {
3288                        set global_options(ports_do_dependents) yes
3289                    }
3290                    s {
3291                        set global_options(ports_source_only) yes
3292                    }
3293                    b {
3294                        set global_options(ports_binary_only) yes
3295                    }
3296                    c {
3297                        set global_options(ports_autoclean) yes
3298                    }
3299                    k {
3300                        set global_options(ports_autoclean) no
3301                    }
3302                    t {
3303                        set global_options(ports_trace) yes
3304                    }
3305                    y {
3306                        set global_options(ports_dryrun) yes
3307                    }
3308                    F {
3309                        # Name a command file to process
3310                        advance
3311                        if {[moreargs]} {
3312                            lappend ui_options(ports_commandfiles) [lookahead]
3313                        }
3314                    }
3315                    D {
3316                        advance
3317                        if {[moreargs]} {
3318                            cd [lookahead]
3319                        }
3320                        break
3321                    }
3322                    default {
3323                        print_usage; exit 1
3324                    }
3325                }
3326            }
3327        }
3328
3329        advance
3330    }
3331}
3332
3333
3334proc process_cmd { argv } {
3335    global cmd_argc cmd_argv cmd_argn
3336    global global_options global_options_base private_options ui_options
3337    global current_portdir
3338    global cmd_implied_options
3339    set cmd_argv $argv
3340    set cmd_argc [llength $argv]
3341    set cmd_argn 0
3342
3343    set action_status 0
3344
3345    # Process an action if there is one
3346    while {$action_status == 0 && [moreargs]} {
3347        set action [lookahead]
3348        advance
3349       
3350        # Handle command separator
3351        if { $action == ";" } {
3352            continue
3353        }
3354       
3355        # Handle a comment
3356        if { [string index $action 0] == "#" } {
3357            while { [moreargs] } { advance }
3358            break
3359        }
3360       
3361        # Always start out processing an action in current_portdir
3362        cd $current_portdir
3363       
3364        # Reset global_options from base before each action, as we munge it just below...
3365        array unset global_options
3366        array set global_options $global_options_base
3367       
3368        if {[info exists cmd_implied_options($action)]} {
3369            array set global_options $cmd_implied_options($action)
3370        }
3371
3372        # Find an action to execute
3373        set action_proc [find_action_proc $action]
3374        if { $action_proc == "" } {
3375            puts "Unrecognized action \"$action\""
3376            set action_status 1
3377            break
3378        }
3379
3380        # Parse options that will be unique to this action
3381        # (to avoid abiguity with -variants and a default port, either -- must be
3382        # used to terminate option processing, or the pseudo-port current must be specified).
3383        if {[catch {parse_options $action ui_options global_options} result]} {
3384            global errorInfo
3385            ui_debug "$errorInfo"
3386            ui_error $result
3387            set action_status 1
3388            break
3389        }
3390
3391        # What kind of arguments does the command expect?
3392        set expand [action_needs_portlist $action]
3393
3394        # Parse action arguments, setting a special flag if there were none
3395        # We otherwise can't tell the difference between arguments that evaluate
3396        # to the empty set, and the empty set itself.
3397        set portlist {}
3398        switch -- [lookahead] {
3399            ;       -
3400            _EOF_ {
3401                set private_options(ports_no_args) yes
3402            }
3403            default {
3404                if {[action_args_const none] == $expand} {
3405                    ui_error "$action does not accept string arguments"
3406                    set action_status 1
3407                    break
3408                } elseif {[action_args_const strings] == $expand} {
3409                    while { [moreargs] && ![match ";"] } {
3410                        lappend portlist [lookahead]
3411                        advance
3412                    }
3413                } elseif {[action_args_const ports] == $expand} {
3414                    # Parse port specifications into portlist
3415                    if {![portExpr portlist]} {
3416                        ui_error "Improper expression syntax while processing parameters"
3417                        set action_status 1
3418                        break
3419                    }
3420                }
3421            }
3422        }
3423       
3424        # execute the action
3425        set action_status [$action_proc $action $portlist [array get global_options]]
3426
3427        # semaphore to exit
3428        if {$action_status == -999} break
3429
3430        # If we're not in exit mode then ignore the status from the command
3431        if { ![macports::ui_isset ports_exit] } {
3432            set action_status 0
3433        }
3434    }
3435   
3436    return $action_status
3437}
3438
3439
3440proc complete_portname { text state } { 
3441    global complete_choices complete_position
3442   
3443    if {$state == 0} {
3444        set complete_position 0
3445        set complete_choices {}
3446
3447        # Build a list of ports with text as their prefix
3448        if {[catch {set res [mportsearch "${text}*" false glob]} result]} {
3449            global errorInfo
3450            ui_debug "$errorInfo"
3451            fatal "search for portname $pattern failed: $result"
3452        }
3453        foreach {name info} $res {
3454            lappend complete_choices $name
3455        }
3456    }
3457   
3458    set word [lindex $complete_choices $complete_position]
3459    incr complete_position
3460   
3461    return $word
3462}
3463
3464
3465proc complete_action { text state } {   
3466    global action_array
3467    global complete_choices complete_position
3468
3469    if {$state == 0} {
3470        set complete_position 0
3471        set complete_choices [array names action_array "[string tolower $text]*"]
3472    }
3473
3474    set word [lindex $complete_choices $complete_position]
3475    incr complete_position
3476
3477    return $word
3478}
3479
3480
3481proc attempt_completion { text word start end } {
3482    # If the word starts with '~', or contains '.' or '/', then use the build-in
3483    # completion to complete the word
3484    if { [regexp {^~|[/.]} $word] } {
3485        return ""
3486    }
3487
3488    # Decide how to do completion based on where we are in the string
3489    set prefix [string range $text 0 [expr $start - 1]]
3490   
3491    # If only whitespace characters preceed us, or if the
3492    # previous non-whitespace character was a ;, then we're
3493    # an action (the first word of a command)
3494    if { [regexp {(^\s*$)|(;\s*$)} $prefix] } {
3495        return complete_action
3496    }
3497   
3498    # Otherwise, do completion on portname
3499    return complete_portname
3500}
3501
3502
3503proc get_next_cmdline { in out use_readline prompt linename } {
3504    upvar $linename line
3505   
3506    set line ""
3507    while { $line == "" } {
3508
3509        if {$use_readline} {
3510            set len [readline read -attempted_completion attempt_completion line $prompt]
3511        } else {
3512            puts -nonewline $out $prompt
3513            flush $out
3514            set len [gets $in line]
3515        }
3516
3517        if { $len < 0 } {
3518            return -1
3519        }
3520       
3521        set line [string trim $line]
3522
3523        if { $use_readline && $line != "" } {
3524            rl_history add $line
3525        }
3526    }
3527   
3528    return [llength $line]
3529}
3530
3531
3532proc process_command_file { in } {
3533    global current_portdir
3534
3535    # Initialize readline
3536    set isstdin [string match $in "stdin"]
3537    set name "port"
3538    set use_readline [expr $isstdin && [readline init $name]]
3539    set history_file [file normalize "${macports::macports_user_dir}/history"]
3540
3541    # Read readline history
3542    if {$use_readline && [file isdirectory $macports::macports_user_dir]} {
3543        rl_history read $history_file
3544        rl_history stifle 100
3545    }
3546
3547    # Be noisy, if appropriate
3548    set noisy [expr $isstdin && ![macports::ui_isset ports_quiet]]
3549    if { $noisy } {
3550        puts "MacPorts [macports::version]"
3551        puts "Entering interactive mode... (\"help\" for help, \"quit\" to quit)"
3552    }
3553
3554    # Main command loop
3555    set exit_status 0
3556    while { $exit_status == 0 } {
3557
3558        # Calculate our prompt
3559        if { $noisy } {
3560            set shortdir [eval file join [lrange [file split $current_portdir] end-1 end]]
3561            set prompt "\[$shortdir\] > "
3562        } else {
3563            set prompt ""
3564        }
3565
3566        # Get a command line
3567        if { [get_next_cmdline $in stdout $use_readline $prompt line] <= 0  } {
3568            puts ""
3569            break
3570        }
3571
3572        # Process the command
3573        set exit_status [process_cmd $line]
3574       
3575        # Check for semaphore to exit
3576        if {$exit_status == -999} break
3577       
3578        # Ignore status unless we're in error-exit mode
3579        if { ![macports::ui_isset ports_exit] } {
3580            set exit_status 0
3581        }
3582    }
3583
3584    # Create macports user directory if it does not exist yet
3585    if {$use_readline && ![file isdirectory $macports::macports_user_dir]} {
3586        file mkdir $macports::macports_user_dir
3587    }
3588    # Save readine history
3589    if {$use_readline && [file isdirectory $macports::macports_user_dir]} {
3590        rl_history write $history_file
3591    }
3592
3593    # Say goodbye
3594    if { $noisy } {
3595        puts "Goodbye"
3596    }
3597
3598    return $exit_status
3599}
3600
3601
3602proc process_command_files { filelist } {
3603    set exit_status 0
3604
3605    # For each file in the command list, process commands
3606    # in the file
3607    foreach file $filelist {
3608        if {$file == "-"} {
3609            set in stdin
3610        } else {
3611            if {[catch {set in [open $file]} result]} {
3612                fatal "Failed to open command file; $result"
3613            }
3614        }
3615
3616        set exit_status [process_command_file $in]
3617
3618        if {$in != "stdin"} {
3619            close $in
3620        }
3621
3622        # Check for semaphore to exit
3623        if {$exit_status == -999} {
3624            set exit_status 0
3625            break
3626        }
3627
3628        # Ignore status unless we're in error-exit mode
3629        if { ![macports::ui_isset ports_exit] } {
3630            set exit_status 0
3631        }
3632    }
3633
3634    return $exit_status
3635}
3636
3637
3638##########################################
3639# Main
3640##########################################
3641
3642# Global arrays passed to the macports1.0 layer
3643array set ui_options        {}
3644array set global_options    {}
3645array set global_variations {}
3646
3647# Global options private to this script
3648array set private_options {}
3649
3650# Make sure we get the size of the terminal
3651# We do this here to save it in the boot_env, in case we determined it manually
3652term_init_size
3653
3654# Save off a copy of the environment before mportinit monkeys with it
3655global env boot_env
3656array set boot_env [array get env]
3657
3658global argv0
3659global cmdname
3660set cmdname [file tail $argv0]
3661
3662# Setp cmd_argv to match argv
3663global argc argv
3664global cmd_argc cmd_argv cmd_argn
3665set cmd_argv $argv
3666set cmd_argc $argc
3667set cmd_argn 0
3668
3669# If we've been invoked as portf, then the first argument is assumed
3670# to be the name of a command file (i.e., there is an implicit -F
3671# before any arguments).
3672if {[moreargs] && $cmdname == "portf"} {
3673    lappend ui_options(ports_commandfiles) [lookahead]
3674    advance
3675}
3676
3677# Parse global options that will affect all subsequent commands
3678if {[catch {parse_options "global" ui_options global_options} result]} {
3679    puts "Error: $result"
3680    print_usage
3681    exit 1
3682}
3683
3684# Get arguments remaining after option processing
3685set remaining_args [lrange $cmd_argv $cmd_argn end]
3686
3687# Initialize mport
3688# This must be done following parse of global options, as some options are
3689# evaluated by mportinit.
3690if {[catch {mportinit ui_options global_options global_variations} result]} {
3691    global errorInfo
3692    puts "$errorInfo"
3693    fatal "Failed to initialize MacPorts, $result"
3694}
3695
3696# If we have no arguments remaining after option processing then force
3697# interactive mode
3698if { [llength $remaining_args] == 0 && ![info exists ui_options(ports_commandfiles)] } {
3699    lappend ui_options(ports_commandfiles) -
3700}
3701
3702# Set up some global state for our code
3703global current_portdir
3704set current_portdir [pwd]
3705
3706# Freeze global_options into global_options_base; global_options
3707# will be reset to global_options_base prior to processing each command.
3708global global_options_base
3709set global_options_base [array get global_options]
3710
3711# First process any remaining args as action(s)
3712global exit_status
3713set exit_status 0
3714if { [llength $remaining_args] > 0 } {
3715
3716    # If there are remaining arguments, process those as a command
3717
3718    # Exit immediately, by default, unless we're going to be processing command files
3719    if {![info exists ui_options(ports_commandfiles)]} {
3720        set ui_options(ports_exit) yes
3721    }
3722    set exit_status [process_cmd $remaining_args]
3723}
3724
3725# Process any prescribed command files, including standard input
3726if { $exit_status == 0 && [info exists ui_options(ports_commandfiles)] } {
3727    set exit_status [process_command_files $ui_options(ports_commandfiles)]
3728}
3729
3730# Return with exit_status
3731exit $exit_status
Note: See TracBrowser for help on using the repository browser.