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

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

port log <port> command now shows log file for port

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 121.5 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 51826 2009-06-04 16:14: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:, portdir:, homepage:, epoch:, platforms:, platform:, name:,
98long_description:, maintainers:, maintainer:, categories:, category:, version:,
99and 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        ^revision:          { # Handle special port selectors
938            advance
939
940            # Break up the token, because older Tcl switch doesn't support -matchvar
941            regexp {^(\w+):(.*)} $token matchvar field pat
942
943            # Remap friendly names to actual names
944            set field [map_friendly_field_names $field]
945
946            add_multiple_ports reslist [get_matching_ports $pat no regexp $field]
947            set el 1
948        }
949
950        ^depends:           { # A port selector shorthand for depends_lib, depends_build or depends_run
951            advance
952
953            # Break up the token, because older Tcl switch doesn't support -matchvar
954            regexp {^(\w+):(.*)} $token matchvar field pat
955
956            add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_lib"]
957            add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_build"]
958            add_multiple_ports reslist [get_matching_ports $pat no regexp "depends_run"]
959
960            set el 1
961        }
962
963        [][?*]              { # Handle portname glob patterns
964            advance; add_multiple_ports reslist [get_matching_ports $token no glob]
965            set el 1
966        }
967
968        ^\\w+:.+            { # Handle a url by trying to open it as a port and mapping the name
969            advance
970            set name [url_to_portname $token]
971            if {$name != ""} {
972                parsePortSpec version variants options
973                add_to_portlist reslist [list url $token \
974                  name $name \
975                  version $version \
976                  variants [array get variants] \
977                  options [array get options]]
978            } else {
979                ui_error "Can't open URL '$token' as a port"
980                set el 0
981            }
982            set el 1
983        }
984
985        default             { # Treat anything else as a portspec (portname, version, variants, options
986            # or some combination thereof).
987            parseFullPortSpec url name version variants options
988            add_to_portlist reslist [list url $url \
989              name $name \
990              version $version \
991              variants [array get variants] \
992              options [array get options]]
993            set el 1
994        }
995    }
996
997    return $el
998}
999
1000
1001proc add_multiple_ports { resname ports {remainder ""} } {
1002    upvar $resname reslist
1003   
1004    set version ""
1005    array unset variants
1006    array unset options
1007    parsePortSpec version variants options $remainder
1008   
1009    array unset overrides
1010    if {$version != ""} { set overrides(version) $version }
1011    if {[array size variants]} { set overrides(variants) [array get variants] }
1012    if {[array size options]} { set overrides(options) [array get options] }
1013
1014    add_ports_to_portlist reslist $ports [array get overrides]
1015}
1016
1017
1018proc opUnion { a b } {
1019    set result {}
1020   
1021    array unset onetime
1022   
1023    # Walk through each array, adding to result only those items that haven't
1024    # been added before
1025    foreach item $a {
1026        array set port $item
1027        if {[info exists onetime($port(fullname))]} continue
1028        set onetime($port(fullname)) 1
1029        lappend result $item
1030    }
1031
1032    foreach item $b {
1033        array set port $item
1034        if {[info exists onetime($port(fullname))]} continue
1035        set onetime($port(fullname)) 1
1036        lappend result $item
1037    }
1038   
1039    return $result
1040}
1041
1042
1043proc opIntersection { a b } {
1044    set result {}
1045   
1046    # Rules we follow in performing the intersection of two port lists:
1047    #
1048    #   a/, a/          ==> a/
1049    #   a/, b/          ==>
1050    #   a/, a/1.0       ==> a/1.0
1051    #   a/1.0, a/       ==> a/1.0
1052    #   a/1.0, a/2.0    ==>
1053    #
1054    #   If there's an exact match, we take it.
1055    #   If there's a match between simple and descriminated, we take the later.
1056   
1057    # First create a list of the fully descriminated names in b
1058    array unset bfull
1059    set i 0
1060    foreach bitem $b {
1061        array set port $bitem
1062        set bfull($port(fullname)) $i
1063        incr i
1064    }
1065   
1066    # Walk through each item in a, matching against b
1067    foreach aitem $a {
1068        array set port $aitem
1069       
1070        # Quote the fullname and portname to avoid special characters messing up the regexp
1071        set safefullname [regex_pat_sanitize $port(fullname)]
1072       
1073        set simpleform [expr { "$port(name)/" == $port(fullname) }]
1074        if {$simpleform} {
1075            set pat "^${safefullname}"
1076        } else {
1077            set safename [regex_pat_sanitize $port(name)]
1078            set pat "^${safefullname}$|^${safename}/$"
1079        }
1080       
1081        set matches [array names bfull -regexp $pat]
1082        foreach match $matches {
1083            if {$simpleform} {
1084                set i $bfull($match)
1085                lappend result [lindex $b $i]
1086            } else {
1087                lappend result $aitem
1088            }
1089        }
1090    }
1091   
1092    return $result
1093}
1094
1095
1096proc opComplement { a b } {
1097    set result {}
1098   
1099    # Return all elements of a not matching elements in b
1100   
1101    # First create a list of the fully descriminated names in b
1102    array unset bfull
1103    set i 0
1104    foreach bitem $b {
1105        array set port $bitem
1106        set bfull($port(fullname)) $i
1107        incr i
1108    }
1109   
1110    # Walk through each item in a, taking all those items that don't match b
1111    #
1112    # Note: -regexp may not be present in all versions of Tcl we need to work
1113    #       against, in which case we may have to fall back to a slower alternative
1114    #       for those cases. I'm not worrying about that for now, however. -jdb
1115    foreach aitem $a {
1116        array set port $aitem
1117       
1118        # Quote the fullname and portname to avoid special characters messing up the regexp
1119        set safefullname [regex_pat_sanitize $port(fullname)]
1120       
1121        set simpleform [expr { "$port(name)/" == $port(fullname) }]
1122        if {$simpleform} {
1123            set pat "^${safefullname}"
1124        } else {
1125            set safename [regex_pat_sanitize $port(name)]
1126            set pat "^${safefullname}$|^${safename}/$"
1127        }
1128       
1129        set matches [array names bfull -regexp $pat]
1130
1131        # We copy this element to result only if it didn't match against b
1132        if {![llength $matches]} {
1133            lappend result $aitem
1134        }
1135    }
1136   
1137    return $result
1138}
1139
1140
1141proc parseFullPortSpec { urlname namename vername varname optname } {
1142    upvar $urlname porturl
1143    upvar $namename portname
1144    upvar $vername portversion
1145    upvar $varname portvariants
1146    upvar $optname portoptions
1147   
1148    set portname ""
1149    set portversion ""
1150    array unset portvariants
1151    array unset portoptions
1152   
1153    if { [moreargs] } {
1154        # Look first for a potential portname
1155        #
1156        # We need to allow a wide variaty of tokens here, because of actions like "provides"
1157        # so we take a rather lenient view of what a "portname" is. We allow
1158        # anything that doesn't look like either a version, a variant, or an option
1159        set token [lookahead]
1160
1161        set remainder ""
1162        if {![regexp {^(@|[-+]([[:alpha:]_]+[\w\.]*)|[[:alpha:]_]+[\w\.]*=)} $token match]} {
1163            advance
1164            regexp {^([^@]+)(@.*)?} $token match portname remainder
1165           
1166            # If the portname contains a /, then try to use it as a URL
1167            if {[string match "*/*" $portname]} {
1168                set url "file://$portname"
1169                set name [url_to_portname $url 1]
1170                if { $name != "" } {
1171                    # We mapped the url to valid port
1172                    set porturl $url
1173                    set portname $name
1174                    # Continue to parse rest of portspec....
1175                } else {
1176                    # We didn't map the url to a port; treat it
1177                    # as a raw string for something like port contents
1178                    # or cd
1179                    set porturl ""
1180                    # Since this isn't a port, we don't try to parse
1181                    # any remaining portspec....
1182                    return
1183                }
1184            }
1185        }
1186       
1187        # Now parse the rest of the spec
1188        parsePortSpec portversion portvariants portoptions $remainder
1189    }
1190}
1191
1192   
1193proc parsePortSpec { vername varname optname {remainder ""} } {
1194    upvar $vername portversion
1195    upvar $varname portvariants
1196    upvar $optname portoptions
1197   
1198    global global_options
1199   
1200    set portversion ""
1201    array unset portoptions
1202    array set portoptions [array get global_options]
1203    array unset portvariants
1204   
1205    # Parse port version/variants/options
1206    set opt $remainder
1207    set adv 0
1208    set consumed 0
1209    for {set firstTime 1} {$opt != "" || [moreargs]} {set firstTime 0} {
1210   
1211        # Refresh opt as needed
1212        if {$opt == ""} {
1213            if {$adv} advance
1214            set opt [lookahead]
1215            set adv 1
1216            set consumed 0
1217        }
1218       
1219        # Version must be first, if it's there at all
1220        if {$firstTime && [string match {@*} $opt]} {
1221            # Parse the version
1222           
1223            # Strip the @
1224            set opt [string range $opt 1 end]
1225           
1226            # Handle the version
1227            set sepPos [string first "/" $opt]
1228            if {$sepPos >= 0} {
1229                # Version terminated by "/" to disambiguate -variant from part of version
1230                set portversion [string range $opt 0 [expr $sepPos-1]]
1231                set opt [string range $opt [expr $sepPos+1] end]
1232            } else {
1233                # Version terminated by "+", or else is complete
1234                set sepPos [string first "+" $opt]
1235                if {$sepPos >= 0} {
1236                    # Version terminated by "+"
1237                    set portversion [string range $opt 0 [expr $sepPos-1]]
1238                    set opt [string range $opt $sepPos end]
1239                } else {
1240                    # Unterminated version
1241                    set portversion $opt
1242                    set opt ""
1243                }
1244            }
1245            set consumed 1
1246        } else {
1247            # Parse all other options
1248           
1249            # Look first for a variable setting: VARNAME=VALUE
1250            if {[regexp {^([[:alpha:]_]+[\w\.]*)=(.*)} $opt match key val] == 1} {
1251                # It's a variable setting
1252                set portoptions($key) "\"$val\""
1253                set opt ""
1254                set consumed 1
1255            } elseif {[regexp {^([-+])([[:alpha:]_]+[\w\.]*)} $opt match sign variant] == 1} {
1256                # It's a variant
1257                set portvariants($variant) $sign
1258                set opt [string range $opt [expr [string length $variant]+1] end]
1259                set consumed 1
1260            } else {
1261                # Not an option we recognize, so break from port option processing
1262                if { $consumed && $adv } advance
1263                break
1264            }
1265        }
1266    }
1267}
1268
1269
1270##########################################
1271# Action Handlers
1272##########################################
1273
1274proc action_get_usage { action } {
1275    global action_array cmd_opts_array
1276
1277    if {[info exists action_array($action)]} {
1278        set cmds ""
1279        if {[info exists cmd_opts_array($action)]} {
1280            foreach opt $cmd_opts_array($action) {
1281                if {[llength $opt] == 1} {
1282                    set name $opt
1283                    set optc 0
1284                } else {
1285                    set name [lindex $opt 0]
1286                    set optc [lindex $opt 1]
1287                }
1288
1289                append cmds " --$name"
1290
1291                for {set i 1} {$i <= $optc} {incr i} {
1292                    append cmds " <arg$i>"
1293                }
1294            }
1295        }
1296        set args ""
1297        set needed [action_needs_portlist $action]
1298        if {[action_args_const strings] == $needed} {
1299            set args " <arguments>"
1300        } elseif {[action_args_const strings] == $needed} {
1301            set args " <portlist>"
1302        }
1303
1304        set ret "Usage: "
1305        set len [string length $action]
1306        append ret [wrap "$action$cmds$args" 0 [string repeat " " [expr 8 + $len]] 0]
1307        append ret "\n"
1308
1309        return $ret
1310    }
1311
1312    return -1
1313}
1314
1315proc action_usage { action portlist opts } {
1316    if {[llength $portlist] == 0} {
1317        print_usage
1318        return 0
1319    }
1320
1321    foreach topic $portlist {
1322        set usage [action_get_usage $topic]
1323        if {$usage != -1} {
1324           puts -nonewline stderr $usage
1325        } else {
1326            ui_error "No usage for topic $topic"
1327            return 1
1328        }
1329    }
1330}
1331
1332
1333proc action_help { action portlist opts } {
1334    set helpfile "$macports::prefix/var/macports/port-help.tcl"
1335
1336    if {[llength $portlist] == 0} {
1337        print_help
1338        return 0
1339    }
1340
1341    if {[file exists $helpfile]} {
1342        if {[catch {source $helpfile} err]} {
1343            puts stderr "Error reading helpfile $helpfile: $err"
1344            return 1
1345        }
1346    } else {
1347        puts stderr "Unable to open help file $helpfile"
1348        return 1
1349    }
1350
1351    foreach topic $portlist {
1352        if {![info exists porthelp($topic)]} {
1353            puts stderr "No help for topic $topic"
1354            return 1
1355        }
1356
1357        set usage [action_get_usage $topic]
1358        if {$usage != -1} {
1359           puts -nonewline stderr $usage
1360        } else {
1361            ui_error "No usage for topic $topic"
1362            return 1
1363        }
1364
1365        puts stderr $porthelp($topic)
1366    }
1367
1368    return 0
1369}
1370
1371
1372proc action_log { action portlist opts } {
1373    set logfile "$macports::prefix/var/macports/logs/"
1374
1375    if {[llength $portlist] == 0} {
1376        print_help
1377        return 0
1378    }
1379    foreachport $portlist {
1380        # If we have a url, use that, since it's most specific
1381        # otherwise try to map the portname to a url
1382        if {$porturl eq ""} {
1383        # Verify the portname, getting portinfo to map to a porturl
1384            if {[catch {mportlookup $portname} result]} {
1385                ui_debug "$::errorInfo"
1386                break_softcontinue "lookup of portname $portname failed: $result" 1 status
1387            }
1388            if {[llength $result] < 2} {
1389                break_softcontinue "Port $portname not found" 1 status
1390            }
1391            array unset portinfo
1392            array set portinfo [lindex $result 1]
1393            set porturl $portinfo(porturl)
1394            set portdir $portinfo(portdir)
1395        } elseif {$porturl ne "file://."} {
1396            # Extract the portdir from porturl and use it to search PortIndex.
1397            # Only the last two elements of the path (porturl) make up the
1398            # portdir.
1399            set portdir [file split [macports::getportdir $porturl]]
1400            set lsize [llength $portdir]
1401            set portdir \
1402                [file join [lindex $portdir [expr $lsize - 2]] \
1403                           [lindex $portdir [expr $lsize - 1]]]
1404            if {[catch {mportsearch $portdir no exact portdir} result]} {
1405                ui_debug "$::errorInfo"
1406                break_softcontinue "Portdir $portdir not found" 1 status
1407            }
1408            if {[llength $result] < 2} {
1409                break_softcontinue "Portdir $portdir not found" 1 status
1410            }
1411            array unset portinfo
1412            array set portinfo [lindex $result 1]
1413        }
1414        if {[catch {set mport [mportopen $porturl [array get options] [array get merged_variations]]} result]} {
1415            ui_debug "$::errorInfo"
1416            break_softcontinue "Unable to open port: $result" 1 status
1417         }
1418         array unset portinfo
1419         array set portinfo [mportinfo $mport]
1420
1421         append logfile $portinfo(name)
1422         append logfile "/main.log"
1423         mportclose $mport                       
1424         set fp [open $logfile r]
1425         set data [read $fp]
1426         close $fp
1427         puts $data
1428    }
1429    return 0
1430}
1431
1432
1433proc action_info { action portlist opts } {
1434    global global_variations
1435    set status 0
1436    if {[require_portlist portlist]} {
1437        return 1
1438    }
1439
1440    set separator ""
1441    foreachport $portlist {
1442        puts -nonewline $separator
1443        # If we have a url, use that, since it's most specific
1444        # otherwise try to map the portname to a url
1445        if {$porturl eq ""} {
1446        # Verify the portname, getting portinfo to map to a porturl
1447            if {[catch {mportlookup $portname} result]} {
1448                ui_debug "$::errorInfo"
1449                break_softcontinue "lookup of portname $portname failed: $result" 1 status
1450            }
1451            if {[llength $result] < 2} {
1452                break_softcontinue "Port $portname not found" 1 status
1453            }
1454            array unset portinfo
1455            array set portinfo [lindex $result 1]
1456            set porturl $portinfo(porturl)
1457            set portdir $portinfo(portdir)
1458        } elseif {$porturl ne "file://."} {
1459            # Extract the portdir from porturl and use it to search PortIndex.
1460            # Only the last two elements of the path (porturl) make up the
1461            # portdir.
1462            set portdir [file split [macports::getportdir $porturl]]
1463            set lsize [llength $portdir]
1464            set portdir \
1465                [file join [lindex $portdir [expr $lsize - 2]] \
1466                           [lindex $portdir [expr $lsize - 1]]]
1467            if {[catch {mportsearch $portdir no exact portdir} result]} {
1468                ui_debug "$::errorInfo"
1469                break_softcontinue "Portdir $portdir not found" 1 status
1470            }
1471            if {[llength $result] < 2} {
1472                break_softcontinue "Portdir $portdir not found" 1 status
1473            }
1474            array unset portinfo
1475            array set portinfo [lindex $result 1]
1476        }
1477
1478        if {!([info exists options(ports_info_index)] && $options(ports_info_index) eq "yes")} {
1479            # Add any global_variations to the variations
1480            # specified for the port (so we get e.g. dependencies right)
1481            array unset merged_variations
1482            array set merged_variations [array get variations]
1483            foreach { variation value } [array get global_variations] { 
1484                if { ![info exists merged_variations($variation)] } { 
1485                    set merged_variations($variation) $value 
1486                } 
1487            }
1488 
1489            if {[catch {set mport [mportopen $porturl [array get options] [array get merged_variations]]} result]} {
1490                ui_debug "$::errorInfo"
1491                break_softcontinue "Unable to open port: $result" 1 status
1492            }
1493            array unset portinfo
1494            array set portinfo [mportinfo $mport]
1495            mportclose $mport
1496            if {[info exists portdir]} {
1497                set portinfo(portdir) $portdir
1498            }
1499        } elseif {![info exists portinfo]} {
1500            ui_warn "port info --index does not work with 'current' pseudo-port"
1501            continue
1502        }
1503        array unset options ports_info_index
1504
1505        # Understand which info items are actually lists
1506        # (this could be overloaded to provide a generic formatting code to
1507        # allow us to, say, split off the prefix on libs)
1508        array set list_map "
1509            categories      1
1510            depends_build   1
1511            depends_lib     1
1512            depends_run     1
1513            maintainers     1
1514            platforms       1
1515            variants        1
1516        "
1517
1518        # Label map for pretty printing
1519        array set pretty_label {
1520            heading     ""
1521            variants    Variants
1522            depends_build "Build Dependencies"
1523            depends_run "Runtime Dependencies"
1524            depends_lib "Library Dependencies"
1525            description "Brief Description"
1526            long_description "Description"
1527            fullname    "Full Name: "
1528            homepage    Homepage
1529            platforms   Platforms
1530            maintainers Maintainers
1531            license     License
1532        }
1533
1534        # Wrap-length map for pretty printing
1535        array set pretty_wrap {
1536            heading 0
1537            variants 22
1538            depends_build 22
1539            depends_run 22
1540            depends_lib 22
1541            description 22
1542            long_description 22
1543            homepage 22
1544            platforms 22
1545            license 22
1546            maintainers 22
1547        }
1548
1549        # Interpret a convenient field abbreviation
1550        if {[info exists options(ports_info_depends)] && $options(ports_info_depends) == "yes"} {
1551            array unset options ports_info_depends
1552            set options(ports_info_depends_build) yes
1553            set options(ports_info_depends_lib) yes
1554            set options(ports_info_depends_run) yes
1555        }
1556               
1557        # Set up our field separators
1558        set show_label 1
1559        set field_sep "\n"
1560        set subfield_sep ", "
1561        set pretty_print 0
1562       
1563        # For human-readable summary, which is the default with no options
1564        if {![array size options]} {
1565            set pretty_print 1
1566        } elseif {[info exists options(ports_info_pretty)]} {
1567            set pretty_print 1
1568            array unset options ports_info_pretty
1569        }
1570
1571        # Tune for sort(1)
1572        if {[info exists options(ports_info_line)]} {
1573            array unset options ports_info_line
1574            set show_label 0
1575            set field_sep "\t"
1576            set subfield_sep ","
1577        }
1578       
1579        # Figure out whether to show field name
1580        set quiet [macports::ui_isset ports_quiet]
1581        if {$quiet} {
1582            set show_label 0
1583        }
1584        # In pretty-print mode we also suppress messages, even though we show
1585        # most of the labels:
1586        if {$pretty_print} {
1587            set quiet 1
1588        }
1589
1590        # Spin through action options, emitting information for any found
1591        set fields {}
1592        set opts_todo [array names options ports_info_*]
1593        set fields_tried {}
1594        if {![llength $opts_todo]} {
1595            set opts_todo {ports_info_heading ports_info_variants
1596                ports_info_skip_line
1597                ports_info_long_description ports_info_homepage
1598                ports_info_skip_line ports_info_depends_build
1599                ports_info_depends_lib ports_info_depends_run
1600                ports_info_platforms ports_info_license
1601                ports_info_maintainers
1602            }
1603        }
1604        foreach { option } $opts_todo {
1605            set opt [string range $option 11 end]
1606            # Artificial field name for formatting
1607            if {$pretty_print && $opt eq "skip_line"} {
1608                lappend fields ""
1609                continue
1610            }
1611            # Artificial field names to reproduce prettyprinted summary
1612            if {$opt eq "heading"} {
1613                set inf "$portinfo(name) @$portinfo(version)"
1614                set ropt "heading"
1615                if {[info exists portinfo(revision)] && $portinfo(revision) > 0} {
1616                    append inf ", Revision $portinfo(revision)"
1617                }
1618                if {[info exists portinfo(categories)]} {
1619                    append inf " ([join $portinfo(categories) ", "])"
1620                }
1621            } elseif {$opt eq "fullname"} {
1622                set inf "$portinfo(name) @"
1623                append inf [composite_version $portinfo(version) $portinfo(active_variants)]
1624                set ropt "fullname"
1625            } else {
1626                # Map from friendly name
1627                set ropt [map_friendly_field_names $opt]
1628               
1629                # If there's no such info, move on
1630                if {![info exists portinfo($ropt)]} {
1631                    set inf ""
1632                } else {
1633                    set inf [join $portinfo($ropt)]
1634                }
1635            }
1636
1637            # Calculate field label
1638            set label ""
1639            if {$pretty_print} {
1640                if {[info exists pretty_label($ropt)]} {
1641                    set label $pretty_label($ropt)
1642                } else {
1643                    set label $opt
1644                }
1645            } elseif {$show_label} {
1646                set label "$opt: "
1647            }
1648           
1649            # Format the data
1650            if { $ropt eq "maintainers" } {
1651                set inf [unobscure_maintainers $inf]
1652            }
1653            #     ... special formatting for certain fields when prettyprinting
1654            if {$pretty_print} {
1655                if {$ropt eq "variants"} {
1656                    # Use the new format for variants iff it exists in
1657                    # PortInfo. This key currently does not exist outside of
1658                    # trunk (1.8.0).
1659                    array unset vinfo
1660                    if {[info exists portinfo(vinfo)]} {
1661                        array set vinfo $portinfo(vinfo)
1662                    }
1663
1664                    set pi_vars $inf
1665                    set inf {}
1666                    foreach v [lsort $pi_vars] {
1667                        set varmodifier ""
1668                        if {[info exists variations($v)]} {
1669                            # selected by command line, prefixed with +/-
1670                            set varmodifier $variations($v)
1671                        } elseif {[info exists global_variations($v)]} {
1672                            # selected by variants.conf, prefixed with (+)/(-)
1673                            set varmodifier "($global_variations($v))"
1674                            # Retrieve additional information from the new key.
1675                        } elseif {[info exists vinfo]} {
1676                            array unset variant
1677                            array set variant $vinfo($v)
1678                            if {[info exists variant(is_default)]} {
1679                                set varmodifier "\[+]"
1680                            }
1681                        }
1682                        lappend inf "$varmodifier$v"
1683                    }
1684                } elseif {[string match "depend*" $ropt] 
1685                          && ![macports::ui_isset ports_verbose]} {
1686                    set pi_deps $inf
1687                    set inf {}
1688                    foreach d $pi_deps {
1689                        lappend inf [lindex [split $d :] end]
1690                    }
1691                }
1692            } 
1693            #End of special pretty-print formatting for certain fields
1694            if [info exists list_map($ropt)] {
1695                set field [join $inf $subfield_sep]
1696            } else {
1697                set field $inf
1698            }
1699           
1700            # Assemble the entry
1701            if {$pretty_print} {
1702                # The two special fields are considered headings and are
1703                # emitted immediately, rather than waiting. Also they are not
1704                # recorded on the list of fields tried
1705                if {$ropt eq "heading" || $ropt eq "fullname"} {
1706                    puts "$label$field"
1707                    continue
1708                }
1709            }
1710            lappend fields_tried $label
1711            if {$pretty_print} {
1712                if {![string length $field]} {
1713                    continue
1714                }
1715                if {![string length $label]} {
1716                    set wrap_len 0
1717                    if {[info exists pretty_wrap($ropt)]} {
1718                        set wrap_len $pretty_wrap($ropt)
1719                    }
1720                    lappend fields [wrap $field 0 [string repeat " " $wrap_len]]
1721                } else {
1722                    set wrap_len [string length $label]
1723                    if {[info exists pretty_wrap($ropt)]} {
1724                        set wrap_len $pretty_wrap($ropt)
1725                    }
1726                    lappend fields [wraplabel $label $field 0 [string repeat " " $wrap_len]]
1727                }
1728
1729            } else { # Not pretty print
1730                lappend fields "$label$field"
1731            }
1732        }
1733
1734        # Now output all that information:
1735        if {[llength $fields]} {
1736            puts [join $fields $field_sep]
1737        } else {
1738            if {$pretty_print && [llength $fields_tried]} {
1739                puts -nonewline "$portinfo(name) has no "
1740                puts [join $fields_tried ", "]
1741            }
1742        }
1743        set separator "--\n"
1744    }
1745   
1746    return $status
1747}
1748
1749
1750proc action_location { action portlist opts } {
1751    set status 0
1752    if {[require_portlist portlist]} {
1753        return 1
1754    }
1755    foreachport $portlist {
1756        if { [catch {set ilist [registry_installed $portname [composite_version $portversion [array get variations]]]} result] } {
1757            global errorInfo
1758            ui_debug "$errorInfo"
1759            break_softcontinue "port location failed: $result" 1 status
1760        } else {
1761            # set portname again since the one we were passed may not have had the correct case
1762            set portname [lindex $ilist 0]
1763            set version [lindex $ilist 1]
1764            set revision [lindex $ilist 2]
1765            set variants [lindex $ilist 3]
1766        }
1767
1768        set ref [registry::open_entry $portname $version $revision $variants]
1769        if { [string equal [registry::property_retrieve $ref installtype] "image"] } {
1770            set imagedir [registry::property_retrieve $ref imagedir]
1771            if {![macports::ui_isset ports_quiet]} {
1772                puts "Port $portname ${version}_${revision}${variants} is installed as an image in:"
1773            }
1774            puts $imagedir
1775        } else {
1776            break_softcontinue "Port $portname is not installed as an image." 1 status
1777        }
1778    }
1779   
1780    return $status
1781}
1782
1783
1784proc action_notes { action portlist opts } {
1785    if {[require_portlist portlist]} {
1786        return 1
1787    }
1788
1789    foreachport $portlist {
1790        if {$porturl eq ""} {
1791            # Look up the port.
1792            if {[catch {mportlookup $portname} result]} {
1793                ui_debug $::errorInfo
1794                break_softcontinue "The lookup of '$portname' failed: $result" \
1795                                1 status
1796            }
1797            if {[llength $result] < 2} {
1798                break_softcontinue "The port '$portname' was not found" 1 status
1799            }
1800
1801            # Retrieve the port's URL.
1802            array unset portinfo
1803            array set portinfo [lindex $result 1]
1804            set porturl $portinfo(porturl)
1805        }
1806
1807        # Open the Portfile associated with this port.
1808        if {[catch {set mport [mportopen $porturl [array get options] \
1809                                         [array get merged_variations]]} \
1810                   result]} {
1811            ui_debug $::errorInfo
1812            break_softcontinue [concat "The URL '$porturl' could not be" \
1813                                       "opened: $result"] 1 status
1814        }
1815        array unset portinfo
1816        array set portinfo [mportinfo $mport]
1817        mportclose $mport
1818
1819        # Return the notes associated with this Portfile.
1820        if {[info exists portinfo(notes)]} {
1821            set portnotes $portinfo(notes)
1822        } else {
1823            set portnotes {}
1824        }
1825
1826        # Retrieve the port's name once more to ensure it has the proper case.
1827        set portname $portinfo(name)
1828
1829        # Display the notes.
1830        if {![macports::ui_isset ports_quiet]} {
1831            if {$portnotes ne {}} {
1832                puts "$portname has the following notes:"
1833                puts [wrap $portnotes 0 "  " 1]
1834            } else {
1835                puts "$portname has no notes."
1836            }
1837        }
1838    }
1839}
1840
1841
1842proc action_provides { action portlist opts } {
1843    # In this case, portname is going to be used for the filename... since
1844    # that is the first argument we expect... perhaps there is a better way
1845    # to do this?
1846    if { ![llength $portlist] } {
1847        ui_error "Please specify a filename to check which port provides that file."
1848        return 1
1849    }
1850    foreach filename $portlist {
1851        set file [file normalize $filename]
1852        if {[file exists $file]} {
1853            if {![file isdirectory $file]} {
1854                set port [registry::file_registered $file]
1855                if { $port != 0 } {
1856                    puts "$file is provided by: $port"
1857                } else {
1858                    puts "$file is not provided by a MacPorts port."
1859                }
1860            } else {
1861                puts "$file is a directory."
1862            }
1863        } else {
1864            puts "$file does not exist."
1865        }
1866    }
1867    registry::close_file_map
1868   
1869    return 0
1870}
1871
1872
1873proc action_activate { action portlist opts } {
1874    set status 0
1875    if {[require_portlist portlist]} {
1876        return 1
1877    }
1878    foreachport $portlist {
1879        if { [catch {portimage::activate $portname [composite_version $portversion [array get variations]] [array get options]} result] } {
1880            global errorInfo
1881            ui_debug "$errorInfo"
1882            break_softcontinue "port activate failed: $result" 1 status
1883        }
1884    }
1885   
1886    return $status
1887}
1888
1889
1890proc action_deactivate { action portlist opts } {
1891    set status 0
1892    if {[require_portlist portlist]} {
1893        return 1
1894    }
1895    foreachport $portlist {
1896        if { [catch {portimage::deactivate $portname [composite_version $portversion [array get variations]] [array get options]} result] } {
1897            global errorInfo
1898            ui_debug "$errorInfo"
1899            break_softcontinue "port deactivate failed: $result" 1 status
1900        }
1901    }
1902   
1903    return $status
1904}
1905
1906
1907proc action_select { action portlist opts } {
1908    ui_debug "action_select \[$portlist] \[$opts]..."
1909
1910    # Error out if no group is specified.
1911    if {[llength $portlist] < 1} {
1912        ui_error "port select \[--list|--set|--show] <group> \[<version>]"
1913        return 1
1914    }
1915    set group [lindex $portlist 0]
1916
1917    set commands [array names [array set {} $opts]]
1918    # If no command (--set, --show, --list) is specified *but* more than one
1919    # argument is specified, default to the set command.
1920    if {[llength $commands] < 1 && [llength $portlist] > 1} {
1921        set command set
1922        ui_debug [concat "Although no command was specified, more than " \
1923                         "one argument was specified.  Defaulting to the " \
1924                         "'set' command..."]
1925    # If no command (--set, --show, --list) is specified *and* less than two
1926    # argument are specified, default to the show command.
1927    } elseif {[llength $commands] < 1} {
1928        set command show
1929        ui_debug [concat "No command was specified. Defaulting to the " \
1930                         "'show' command..."]
1931    # Only allow one command to be specified at a time.
1932    } elseif {[llength $commands] > 1} {
1933        ui_error [concat "Multiple commands were specified. Only one " \
1934                         "command may be specified at a time."]
1935        return 1
1936    } else {
1937        set command [string map {ports_select_ ""} [lindex $commands 0]]
1938        ui_debug "The '$command' command was specified."
1939    }
1940
1941    switch -- $command {
1942        list {
1943            if {[llength $portlist] > 1} {
1944                ui_warn [concat "The 'list' command does not expect any " \
1945                                "arguments. Extra arguments will be ignored."]
1946            }
1947
1948            # On error mportselect returns with the code 'error'.
1949            if {[catch {mportselect $command $group} versions]} {
1950                ui_error "The 'list' command failed: $versions"
1951                return 1
1952            }
1953
1954            puts "Available Versions:"
1955            foreach v $versions {
1956                puts "\t$v"
1957            }
1958            return 0
1959        }
1960        set {
1961            if {[llength $portlist] < 2} {
1962                ui_error [concat "The 'set' command expects two " \
1963                                 "arguments: <group>, <version>"]
1964                return 1
1965            } elseif {[llength $portlist] > 2} {
1966                ui_warn [concat "The 'set' command only expects two " \
1967                                "arguments. Extra arguments will be " \
1968                                "ignored."]
1969            }
1970            set version [lindex $portlist 1]
1971
1972            puts -nonewline "Selecting '$version' for '$group' "
1973            if {[catch {mportselect $command $group $version} result]} {
1974                puts "failed: $result"
1975                return 1
1976            }
1977            puts "succeeded. '$version' is now active."
1978            return 0
1979        }
1980        show {
1981            if {[llength $portlist] > 1} {
1982                ui_warn [concat "The 'show' command does not expect any " \
1983                                "arguments. Extra arguments will be ignored."]
1984            }
1985
1986            if {[catch {mportselect $command $group} selected_version]} {
1987                ui_error "The 'show' command failed: $selected_version"
1988                return 1
1989            }
1990            puts [concat "The currently selected version for '$group' is " \
1991                         "'$selected_version'."]
1992            return 0
1993        }
1994        default {
1995            ui_error "An unknown command '$command' was specified."
1996            return 1
1997        }
1998    }
1999}
2000
2001
2002proc action_selfupdate { action portlist opts } {
2003    global global_options
2004    if { [catch {macports::selfupdate [array get global_options]} result ] } {
2005        global errorInfo
2006        ui_debug "$errorInfo"
2007        fatal "port selfupdate failed: $result"
2008    }
2009   
2010    return 0
2011}
2012
2013
2014proc action_upgrade { action portlist opts } {
2015    global global_variations
2016    if {[require_portlist portlist]} {
2017        return 1
2018    }
2019    # shared depscache for all ports in the list
2020    array set depscache {}
2021    foreachport $portlist {
2022        if {![registry::entry_exists_for_name $portname]} {
2023            ui_error "$portname is not installed"
2024            return 1
2025        }
2026        if {![info exists depscache(port:$portname)]} {
2027            # Global variations will have to be merged into the specified
2028            # variations, but perhaps after the installed variations are
2029            # merged. So we pass them into upgrade:
2030            macports::upgrade $portname "port:$portname" [array get global_variations] [array get variations] [array get options] depscache
2031        }
2032    }
2033
2034    return 0
2035}
2036
2037
2038proc action_version { action portlist opts } {
2039    puts "Version: [macports::version]"
2040    return 0
2041}
2042
2043
2044proc action_platform { action portlist opts } {
2045#   global os.platform os.major os.arch
2046    global tcl_platform
2047    set os_platform [string tolower $tcl_platform(os)]
2048    set os_version $tcl_platform(osVersion)
2049    set os_arch $tcl_platform(machine)
2050    if {$os_arch == "Power Macintosh"} { set os_arch "powerpc" }
2051    if {$os_arch == "i586" || $os_arch == "i686"} { set os_arch "i386" }
2052    set os_major [lindex [split $tcl_platform(osVersion) .] 0]
2053#   puts "Platform: ${os.platform} ${os.major} ${os.arch}"
2054    puts "Platform: ${os_platform} ${os_major} ${os_arch}"
2055    return 0
2056}
2057
2058
2059proc action_compact { action portlist opts } {
2060    set status 0
2061    if {[require_portlist portlist]} {
2062        return 1
2063    }
2064    foreachport $portlist {
2065        if { [catch {portimage::compact $portname [composite_version $portversion [array get variations]]} result] } {
2066            global errorInfo
2067            ui_debug "$errorInfo"
2068            break_softcontinue "port compact failed: $result" 1 status
2069        }
2070    }
2071
2072    return $status
2073}
2074
2075
2076proc action_uncompact { action portlist opts } {
2077    set status 0
2078    if {[require_portlist portlist]} {
2079        return 1
2080    }
2081    foreachport $portlist {
2082        if { [catch {portimage::uncompact $portname [composite_version $portversion [array get variations]]} result] } {
2083            global errorInfo
2084            ui_debug "$errorInfo"
2085            break_softcontinue "port uncompact failed: $result" 1 status
2086        }
2087    }
2088   
2089    return $status
2090}
2091
2092
2093proc action_dependents { action portlist opts } {
2094    if {[require_portlist portlist]} {
2095        return 1
2096    }
2097    set ilist {}
2098
2099    registry::open_dep_map
2100
2101    foreachport $portlist {
2102        set composite_version [composite_version $portversion [array get variations]]
2103        if { [catch {set ilist [registry::installed $portname $composite_version]} result] } {
2104            global errorInfo
2105            ui_debug "$errorInfo"
2106            break_softcontinue "$result" 1 status
2107        } else {
2108            # set portname again since the one we were passed may not have had the correct case
2109            set portname [lindex [lindex $ilist 0] 0]
2110        }
2111       
2112        set deplist [registry::list_dependents $portname]
2113        if { [llength $deplist] > 0 } {
2114            set dl [list]
2115            # Check the deps first
2116            foreach dep $deplist {
2117                set depport [lindex $dep 2]
2118                if {![macports::ui_isset ports_verbose]} {
2119                    ui_msg "$depport depends on $portname"
2120                } else {
2121                    ui_msg "$depport depends on $portname (by [lindex $dep 1]:)"
2122                }
2123            }
2124        } else {
2125            ui_msg "$portname has no dependents!"
2126        }
2127    }
2128    return 0
2129}
2130
2131
2132proc action_uninstall { action portlist opts } {
2133    set status 0
2134    if {[macports::global_option_isset port_uninstall_old]} {
2135        # if -u then uninstall all inactive ports
2136        # (union these to any other ports user has in the port list)
2137        set portlist [opUnion $portlist [get_inactive_ports]]
2138    } else {
2139        # Otherwise the user hopefully supplied a portlist, or we'll default to the existing directory
2140        if {[require_portlist portlist]} {
2141            return 1
2142        }
2143    }
2144
2145    foreachport $portlist {
2146        if { [catch {portuninstall::uninstall $portname [composite_version $portversion [array get variations]] [array get options]} result] } {
2147            global errorInfo
2148            ui_debug "$errorInfo"
2149
2150            # start gsoc08-privileges
2151            if { [string first "permission denied" $result] != -1 } {
2152                set result "port requires root privileges for this action and needs you to execute 'sudo port uninstall $portname' to continue."
2153                #ui_msg [exec sudo port uninstall $portname]
2154                # The above line is what should be here to let the user simply enter his/her password to uninstall as root.
2155                # However, for some as yet unknown reason, executing it here will not work.
2156            }
2157            # end gsoc08-privileges
2158
2159            break_softcontinue "port uninstall failed: $result" 1 status
2160        }
2161    }
2162
2163    return 0
2164}
2165
2166
2167proc action_installed { action portlist opts } {
2168    global private_options
2169    set status 0
2170    set restrictedList 0
2171    set ilist {}
2172   
2173    if { [llength $portlist] || (![info exists private_options(ports_no_args)] || $private_options(ports_no_args) == "no")} {
2174        set restrictedList 1
2175        foreachport $portlist {
2176            set composite_version [composite_version $portversion [array get variations]]
2177            if { [catch {set ilist [concat $ilist [registry::installed $portname $composite_version]]} result] } {
2178                if {![string match "* not registered as installed." $result]} {
2179                    global errorInfo
2180                    ui_debug "$errorInfo"
2181                    break_softcontinue "port installed failed: $result" 1 status
2182                }
2183            }
2184        }
2185    } else {
2186        if { [catch {set ilist [registry::installed]} result] } {
2187            if {$result != "Registry error: No ports registered as installed."} {
2188                global errorInfo
2189                ui_debug "$errorInfo"
2190                ui_error "port installed failed: $result"
2191                set status 1
2192            }
2193        }
2194    }
2195    if { [llength $ilist] > 0 } {
2196        if {![macports::ui_isset ports_quiet]} {
2197            puts "The following ports are currently installed:"
2198        }
2199        foreach i [portlist_sortint $ilist] {
2200            set iname [lindex $i 0]
2201            set iversion [lindex $i 1]
2202            set irevision [lindex $i 2]
2203            set ivariants [lindex $i 3]
2204            set iactive [lindex $i 4]
2205            if { $iactive == 0 } {
2206                puts "  $iname @${iversion}_${irevision}${ivariants}"
2207            } elseif { $iactive == 1 } {
2208                puts "  $iname @${iversion}_${irevision}${ivariants} (active)"
2209            }
2210        }
2211    } elseif { $restrictedList } {
2212        puts "None of the specified ports are installed."
2213    } else {
2214        puts "No ports are installed."
2215    }
2216   
2217    return $status
2218}
2219
2220
2221proc action_outdated { action portlist opts } {
2222    global macports::registry.installtype private_options
2223    set is_image_mode [expr 0 == [string compare "image" ${macports::registry.installtype}]]
2224
2225    set status 0
2226
2227    # If port names were supplied, limit ourselves to those ports, else check all installed ports
2228    set ilist {}
2229    set restrictedList 0
2230    if { [llength $portlist] || (![info exists private_options(ports_no_args)] || $private_options(ports_no_args) == "no")} {
2231        set restrictedList 1
2232        foreach portspec $portlist {
2233            array set port $portspec
2234            set portname $port(name)
2235            set composite_version [composite_version $port(version) $port(variants)]
2236            if { [catch {set ilist [concat $ilist [registry::installed $portname $composite_version]]} result] } {
2237                if {![string match "* not registered as installed." $result]} {
2238                    global errorInfo
2239                    ui_debug "$errorInfo"
2240                    break_softcontinue "port outdated failed: $result" 1 status
2241                }
2242            }
2243        }
2244    } else {
2245        if { [catch {set ilist [registry::installed]} result] } {
2246            if {$result != "Registry error: No ports registered as installed."} {
2247                global errorInfo
2248                ui_debug "$errorInfo"
2249                ui_error "port installed failed: $result"
2250                set status 1
2251            }
2252        }
2253    }
2254
2255    set num_outdated 0
2256    if { [llength $ilist] > 0 } {   
2257        foreach i $ilist { 
2258       
2259            # Get information about the installed port
2260            set portname [lindex $i 0]
2261            set installed_version [lindex $i 1]
2262            set installed_revision [lindex $i 2]
2263            set installed_compound "${installed_version}_${installed_revision}"
2264
2265            set is_active [lindex $i 4]
2266            if { $is_active == 0 && $is_image_mode } {
2267                continue
2268            }
2269            set installed_epoch [lindex $i 5]
2270
2271            # Get info about the port from the index
2272            if {[catch {set res [mportlookup $portname]} result]} {
2273                global errorInfo
2274                ui_debug "$errorInfo"
2275                break_softcontinue "search for portname $portname failed: $result" 1 status
2276            }
2277            if {[llength $res] < 2} {
2278                if {[macports::ui_isset ports_debug]} {
2279                    puts "$portname ($installed_compound is installed; the port was not found in the port index)"
2280                }
2281                continue
2282            }
2283            array unset portinfo
2284            array set portinfo [lindex $res 1]
2285           
2286            # Get information about latest available version and revision
2287            set latest_version $portinfo(version)
2288            set latest_revision 0
2289            if {[info exists portinfo(revision)] && $portinfo(revision) > 0} { 
2290                set latest_revision $portinfo(revision)
2291            }
2292            set latest_compound "${latest_version}_${latest_revision}"
2293            set latest_epoch 0
2294            if {[info exists portinfo(epoch)]} { 
2295                set latest_epoch $portinfo(epoch)
2296            }
2297           
2298            # Compare versions, first checking epoch, then version, then revision
2299            set comp_result [expr $installed_epoch - $latest_epoch]
2300            if { $comp_result == 0 } {
2301                set comp_result [rpm-vercomp $installed_version $latest_version]
2302                if { $comp_result == 0 } {
2303                    set comp_result [rpm-vercomp $installed_revision $latest_revision]
2304                }
2305            }
2306           
2307            # Report outdated (or, for verbose, predated) versions
2308            if { $comp_result != 0 } {
2309                           
2310                # Form a relation between the versions
2311                set flag ""
2312                if { $comp_result > 0 } {
2313                    set relation ">"
2314                    set flag "!"
2315                } else {
2316                    set relation "<"
2317                }
2318               
2319                # Emit information
2320                if {$comp_result < 0 || [macports::ui_isset ports_verbose]} {
2321               
2322                    if { $num_outdated == 0 && ![macports::ui_isset ports_quiet]} {
2323                        puts "The following installed ports are outdated:"
2324                    }
2325                    incr num_outdated
2326
2327                    puts [format "%-30s %-24s %1s" $portname "$installed_compound $relation $latest_compound" $flag]
2328                }
2329               
2330            }
2331        }
2332       
2333        if { $num_outdated == 0 && ![macports::ui_isset ports_quiet]} {
2334            puts "No installed ports are outdated."
2335        }
2336    } elseif { $restrictedList } {
2337        if {![macports::ui_isset ports_quiet]} {
2338            puts "None of the specified ports are outdated."
2339        }
2340    } else {
2341        if {![macports::ui_isset ports_quiet]} {
2342            puts "No ports are installed."
2343        }
2344    }
2345   
2346    return $status
2347}
2348
2349
2350proc action_contents { action portlist opts } {
2351    set status 0
2352    if {[require_portlist portlist]} {
2353        return 1
2354    }
2355    foreachport $portlist {
2356        if { ![catch {set ilist [registry::installed $portname]} result] } {
2357            # set portname again since the one we were passed may not have had the correct case
2358            set portname [lindex [lindex $ilist 0] 0]
2359        }
2360        set files [registry::port_registered $portname]
2361        if { $files != 0 } {
2362            if { [llength $files] > 0 } {
2363                if {![macports::ui_isset ports_quiet]} {
2364                    puts "Port $portname contains:"
2365                }
2366                foreach file $files {
2367                    puts "  $file"
2368                }
2369            } else {
2370                if {![macports::ui_isset ports_quiet]} {
2371                    puts "Port $portname does not contain any file or is not active."
2372                }
2373            }
2374        } else {
2375            if {![macports::ui_isset ports_quiet]} {
2376                puts "Port $portname is not installed."
2377            }
2378        }
2379    }
2380    registry::close_file_map
2381
2382    return $status
2383}
2384
2385proc action_variants { action portlist opts } {
2386    global global_variations
2387    set status 0
2388    if {[require_portlist portlist]} {
2389        return 1
2390    }
2391    foreachport $portlist {
2392        if {$porturl eq ""} {
2393            # look up port
2394            if {[catch {mportlookup $portname} result]} {
2395                global errorInfo
2396                ui_debug "$errorInfo"
2397                break_softcontinue "lookup of portname $portname failed: $result" 1 status
2398            }
2399            if {[llength $result] < 2} {
2400                break_softcontinue "Port $portname not found" 1 status
2401            }
2402
2403            array unset portinfo
2404            array set portinfo [lindex $result 1]
2405
2406            set porturl $portinfo(porturl)
2407            set portdir $portinfo(portdir)
2408        }
2409
2410        if {!([info exists options(ports_variants_index)] && $options(ports_variants_index) eq "yes")} {
2411            if {[catch {set mport [mportopen $porturl [array get options] [array get variations]]} result]} {
2412                ui_debug "$::errorInfo"
2413                break_softcontinue "Unable to open port: $result" 1 status
2414            }
2415            array unset portinfo
2416            array set portinfo [mportinfo $mport]
2417            mportclose $mport
2418            if {[info exists portdir]} {
2419                set portinfo(portdir) $portdir
2420            }
2421        } elseif {![info exists portinfo]} {
2422            ui_warn "port variants --index does not work with 'current' pseudo-port"
2423            continue
2424        }
2425
2426        # set portname again since the one we were passed may not have had the correct case
2427        set portname $portinfo(name)
2428
2429        # if this fails the port doesn't have any variants
2430        if {![info exists portinfo(variants)]} {
2431            if {![macports::ui_isset ports_quiet]} {
2432                puts "$portname has no variants"
2433            }
2434        } else {
2435            array unset vinfo
2436            # Use the new format if it exists.
2437            if {[info exists portinfo(vinfo)]} {
2438                array set vinfo $portinfo(vinfo)
2439            # Otherwise fall back to the old format.
2440            } elseif {[info exists portinfo(variant_desc)]} {
2441                array set vdescriptions $portinfo(variant_desc)
2442            }
2443
2444            # print out all the variants
2445            if {![macports::ui_isset ports_quiet]} {
2446                puts "$portname has the variants:"
2447            }
2448            foreach v [lsort $portinfo(variants)] {
2449                unset -nocomplain vconflicts vdescription vrequires
2450                # Retrieve variants' information from the new format.
2451                if {[info exists vinfo]} {
2452                    array unset variant
2453                    array set variant $vinfo($v)
2454
2455                    # Retrieve conflicts, description, is_default, and
2456                    # vrequires.
2457                    if {[info exists variant(conflicts)]} {
2458                        set vconflicts $variant(conflicts)
2459                    }
2460                    if {[info exists variant(description)]} {
2461                        set vdescription $variant(description)
2462                    }
2463
2464                    # XXX Keep these varmodifiers in sync with action_info, or create a wrapper for it
2465                    if {[info exists variations($v)]} {
2466                        set varmodifier "  $variations($v)"
2467                    } elseif {[info exists global_variations($v)]} {
2468                        # selected by variants.conf, prefixed with (+)/(-)
2469                        set varmodifier "($global_variations($v))"
2470                    } elseif {[info exists variant(is_default)]} {
2471                        set varmodifier "\[+]"
2472                    } else {
2473                        set varmodifier "   "
2474                    }
2475                    if {[info exists variant(requires)]} {
2476                        set vrequires $variant(requires)
2477                    }
2478                # Retrieve variants' information from the old format,
2479                # which only consists of the description.
2480                } elseif {[info exists vdescriptions($v)]} {
2481                    set vdescription $vdescriptions($v)
2482                }
2483
2484                if {[info exists vdescription]} {
2485                    puts [wraplabel "$varmodifier$v" [string trim $vdescription] 0 [string repeat " " [expr 5 + [string length $v]]]]
2486                } else {
2487                    puts "$varmodifier$v"
2488                }
2489                if {[info exists vconflicts]} {
2490                    puts "     * conflicts with [string trim $vconflicts]"
2491                }
2492                if {[info exists vrequires]} {
2493                    puts "     * requires [string trim $vrequires]"
2494                }
2495            }
2496        }
2497    }
2498
2499    return $status
2500}
2501
2502
2503proc action_search { action portlist opts } {
2504    global private_options global_options
2505    set status 0
2506    if {![llength $portlist] && [info exists private_options(ports_no_args)] && $private_options(ports_no_args) == "yes"} {
2507        ui_error "You must specify a search pattern"
2508        return 1
2509    }
2510
2511    # Copy global options as we are going to modify the array
2512    array set options [array get global_options]
2513
2514    if {[info exists options(ports_search_depends)] && $options(ports_search_depends) == "yes"} {
2515        array unset options ports_search_depends
2516        set options(ports_search_depends_build) yes
2517        set options(ports_search_depends_lib) yes
2518        set options(ports_search_depends_run) yes
2519    }
2520
2521    # Array to hold given filters
2522    array set filters {}
2523    # Default matchstyle
2524    set filter_matchstyle "none"
2525    set filter_case no
2526    foreach { option } [array names options ports_search_*] {
2527        set opt [string range $option 13 end]
2528
2529        if { $options($option) != "yes" } {
2530            continue
2531        }
2532        switch -- $opt {
2533            exact -
2534            glob -
2535            regex {
2536                set filter_matchstyle $opt
2537                continue
2538            }
2539            case-sensitive {
2540                set filter_case yes
2541                continue
2542            }
2543            line {
2544                continue
2545            }
2546        }
2547
2548        set filters($opt) "yes"
2549    }
2550    # Set default search filter if none was given
2551    if { [array size filters] == 0 } {
2552        set filters(name) "yes"
2553        set filters(description) "yes"
2554    }
2555
2556    set separator ""
2557    foreach portname $portlist {
2558        puts -nonewline $separator
2559
2560        set searchstring $portname
2561        set matchstyle $filter_matchstyle
2562        if {$matchstyle == "none"} {
2563            # Guess if the given string was a glob expression, if not do a substring search
2564            if {[string first "*" $portname] == -1 && [string first "?" $portname] == -1} {
2565                set searchstring "*$portname*"
2566            }
2567            set matchstyle glob
2568        }
2569
2570        set res {}
2571        set portfound 0
2572        foreach { opt } [array get filters] {
2573            # Map from friendly name
2574            set opt [map_friendly_field_names $opt]
2575
2576            if {[catch {eval set matches \[mportsearch \$searchstring $filter_case $matchstyle $opt\]} result]} {
2577                global errorInfo
2578                ui_debug "$errorInfo"
2579                break_softcontinue "search for name $portname failed: $result" 1 status
2580            }
2581
2582            set tmp {}
2583            foreach {name info} $matches {
2584                add_to_portlist tmp [concat [list name $name] $info]
2585            }
2586            set res [opUnion $res $tmp]
2587        }
2588        set res [portlist_sort $res]
2589
2590        set joiner ""
2591        foreach info $res {
2592            array unset portinfo
2593            array set portinfo $info
2594
2595            # XXX is this the right place to verify an entry?
2596            if {![info exists portinfo(name)]} {
2597                puts stderr "Invalid port entry, missing portname"
2598                continue
2599            }
2600            if {![info exists portinfo(description)]} {
2601                puts stderr "Invalid port entry for $portinfo(name), missing description"
2602                continue
2603            }
2604            if {![info exists portinfo(version)]} {
2605                puts stderr "Invalid port entry for $portinfo(name), missing version"
2606                continue
2607            }
2608
2609            if {[macports::ui_isset ports_quiet]} {
2610                puts $portinfo(name)
2611            } else {
2612                if {[info exists options(ports_search_line)]
2613                        && $options(ports_search_line) == "yes"} {
2614                    puts "$portinfo(name)\t$portinfo(version)\t$portinfo(categories)\t$portinfo(description)"
2615                } else {
2616                    puts -nonewline $joiner
2617
2618                    puts -nonewline "$portinfo(name) @$portinfo(version)"
2619                    if {[info exists portinfo(categories)]} {
2620                        puts -nonewline " ([join $portinfo(categories) ", "])"
2621                    }
2622                    puts ""
2623                    puts [wrap [join $portinfo(description)] 0 [string repeat " " 4]]
2624                }
2625            }
2626
2627            set joiner "\n"
2628            set portfound 1
2629        }
2630        if { !$portfound } {
2631            if {![macports::ui_isset ports_quiet]} {
2632                ui_msg "No match for $portname found"
2633            }
2634        } elseif {[llength $res] > 1} {
2635            if {(![info exists global_options(ports_search_line)]
2636                    || $global_options(ports_search_line) != "yes")
2637                    && ![macports::ui_isset ports_quiet]} {
2638                ui_msg "\nFound [llength $res] ports."
2639            }
2640        }
2641
2642        set separator "--\n"
2643    }
2644
2645    array unset options
2646    array unset filters
2647
2648    return $status
2649}
2650
2651
2652proc action_list { action portlist opts } {
2653    global private_options
2654    set status 0
2655   
2656    # Default to list all ports if no portnames are supplied
2657    if { ![llength $portlist] && [info exists private_options(ports_no_args)] && $private_options(ports_no_args) == "yes"} {
2658        add_to_portlist portlist [list name "-all-"]
2659    }
2660   
2661    foreachport $portlist {
2662        if {$portname == "-all-"} {
2663            set search_string ".+"
2664        } else {
2665            set search_string [regex_pat_sanitize $portname]
2666        }
2667       
2668        if {[catch {set res [mportsearch ^$search_string\$ no]} result]} {
2669            global errorInfo
2670            ui_debug "$errorInfo"
2671            break_softcontinue "search for portname $search_string failed: $result" 1 status
2672        }
2673
2674        foreach {name array} $res {
2675            array unset portinfo
2676            array set portinfo $array
2677            set outdir ""
2678            if {[info exists portinfo(portdir)]} {
2679                set outdir $portinfo(portdir)
2680            }
2681            puts [format "%-30s @%-14s %s" $portinfo(name) $portinfo(version) $outdir]
2682        }
2683    }
2684   
2685    return $status
2686}
2687
2688
2689proc action_echo { action portlist opts } {
2690    # Simply echo back the port specs given to this command
2691    foreachport $portlist {
2692        set opts {}
2693        foreach { key value } [array get options] {
2694            lappend opts "$key=$value"
2695        }
2696       
2697        set composite_version [composite_version $portversion [array get variations] 1]
2698        if { $composite_version != "" } {
2699            set ver_field "@$composite_version"
2700        } else {
2701            set ver_field ""
2702        }
2703        puts [format "%-30s %s %s" $portname $ver_field  [join $opts " "]]
2704    }
2705   
2706    return 0
2707}
2708
2709
2710proc action_portcmds { action portlist opts } {
2711    # Operations on the port's directory and Portfile
2712    global env boot_env
2713    global current_portdir
2714
2715    array set local_options $opts
2716   
2717    set status 0
2718    if {[require_portlist portlist]} {
2719        return 1
2720    }
2721    foreachport $portlist {
2722        # If we have a url, use that, since it's most specific, otherwise try to map the portname to a url
2723        if {$porturl == ""} {
2724       
2725            # Verify the portname, getting portinfo to map to a porturl
2726            if {[catch {set res [mportlookup $portname]} result]} {
2727                global errorInfo
2728                ui_debug "$errorInfo"
2729                break_softcontinue "lookup of portname $portname failed: $result" 1 status
2730            }
2731            if {[llength $res] < 2} {
2732                break_softcontinue "Port $portname not found" 1 status
2733            }
2734            array set portinfo [lindex $res 1]
2735            set porturl $portinfo(porturl)
2736        }
2737       
2738       
2739        # Calculate portdir, porturl, and portfile from initial porturl
2740        set portdir [file normalize [macports::getportdir $porturl]]
2741        set porturl "file://${portdir}";    # Rebuild url so it's fully qualified
2742        set portfile "${portdir}/Portfile"
2743       
2744        # Now execute the specific action
2745        if {[file readable $portfile]} {
2746            switch -- $action {
2747                cat {
2748                    # Copy the portfile to standard output
2749                    set f [open $portfile RDONLY]
2750                    while { ![eof $f] } {
2751                        puts -nonewline [read $f 4096]
2752                    }
2753                    close $f
2754                }
2755               
2756                ed - edit {
2757                    # Edit the port's portfile with the user's editor
2758                   
2759                    # Restore our entire environment from start time.
2760                    # We need it to evaluate the editor, and the editor
2761                    # may want stuff from it as well, like TERM.
2762                    array unset env_save; array set env_save [array get env]
2763                    array unset env *; unsetenv *; array set env [array get boot_env]
2764                   
2765                    # Find an editor to edit the portfile
2766                    set editor ""
2767                    if {[info exists local_options(ports_edit_editor)]} {
2768                        set editor [join $local_options(ports_edit_editor)]
2769                    } elseif {[info exists local_options(ports_ed_editor)]} {
2770                        set editor [join $local_options(ports_ed_editor)]
2771                    } else {
2772                        foreach ed { VISUAL EDITOR } {
2773                            if {[info exists env($ed)]} {
2774                                set editor $env($ed)
2775                                break
2776                            }
2777                        }
2778                    }
2779                   
2780                    # Invoke the editor, with a reasonable canned default.
2781                    if { $editor == "" } { set editor "/usr/bin/vi" }
2782                    if {[catch {eval exec >/dev/stdout </dev/stdin $editor $portfile} result]} {
2783                        global errorInfo
2784                        ui_debug "$errorInfo"
2785                        break_softcontinue "unable to invoke editor $editor: $result" 1 status
2786                    }
2787                   
2788                    # Restore internal MacPorts environment
2789                    array unset env *; unsetenv *; array set env [array get env_save]
2790                }
2791
2792                dir {
2793                    # output the path to the port's directory
2794                    puts $portdir
2795                }
2796
2797                work {
2798                    # output the path to the port's work directory
2799                    set workpath [macports::getportworkpath_from_portdir $portdir]
2800                    if {[file exists $workpath]} {
2801                        puts $workpath
2802                    }
2803                }
2804
2805                cd {
2806                    # Change to the port's directory, making it the default
2807                    # port for any future commands
2808                    set current_portdir $portdir
2809                }
2810
2811                url {
2812                    # output the url of the port's directory, suitable to feed back in later as a port descriptor
2813                    puts $porturl
2814                }
2815
2816                file {
2817                    # output the path to the port's portfile
2818                    puts $portfile
2819                }
2820
2821                gohome {
2822                    set homepage ""
2823
2824                    # Get the homepage as read from PortIndex
2825                    if {[info exists portinfo(homepage)]} {
2826                        set homepage $portinfo(homepage)
2827                    }
2828
2829                    # If not available, get the homepage for the port by opening the Portfile
2830                    if {$homepage == "" && ![catch {set ctx [mportopen $porturl]} result]} {
2831                        array set portinfo [mportinfo $ctx]
2832                        if {[info exists portinfo(homepage)]} {
2833                            set homepage $portinfo(homepage)
2834                        }
2835                        mportclose $ctx
2836                    }
2837
2838                    # Try to open a browser to the homepage for the given port
2839                    if { $homepage != "" } {
2840                        system "${macports::autoconf::open_path} '$homepage'"
2841                    } else {
2842                        ui_error [format "No homepage for %s" $portname]
2843                    }
2844                }
2845            }
2846        } else {
2847            break_softcontinue "Could not read $portfile" 1 status
2848        }
2849    }
2850   
2851    return $status
2852}
2853
2854
2855proc action_sync { action portlist opts } {
2856    global global_options
2857
2858    set status 0
2859    if {[catch {mportsync [array get global_options]} result]} {
2860        global errorInfo
2861        ui_debug "$errorInfo"
2862        ui_msg "port sync failed: $result"
2863        set status 1
2864    }
2865   
2866    return $status
2867}
2868
2869
2870proc action_target { action portlist opts } {
2871    global global_variations
2872    set status 0
2873    if {[require_portlist portlist]} {
2874        return 1
2875    }
2876    foreachport $portlist {
2877        set target $action
2878
2879        # If we have a url, use that, since it's most specific
2880        # otherwise try to map the portname to a url
2881        if {$porturl == ""} {
2882            # Verify the portname, getting portinfo to map to a porturl
2883            if {[catch {set res [mportlookup $portname]} result]} {
2884                global errorInfo
2885                ui_debug "$errorInfo"
2886                break_softcontinue "lookup of portname $portname failed: $result" 1 status
2887            }
2888            if {[llength $res] < 2} {
2889                # don't error for ports that are installed but not in the tree
2890                if {[registry::entry_exists_for_name $portname]} {
2891                    ui_warn "Skipping $portname (not in the ports tree)"
2892                    continue
2893                } else {
2894                    break_softcontinue "Port $portname not found" 1 status
2895                }
2896            }
2897            array unset portinfo
2898            array set portinfo [lindex $res 1]
2899            set porturl $portinfo(porturl)
2900        }
2901       
2902        # Add any global_variations to the variations
2903        # specified for the port
2904        foreach { variation value } [array get global_variations] {
2905            if { ![info exists variations($variation)] } {
2906                set variations($variation) $value
2907            }
2908        }
2909
2910        # If version was specified, save it as a version glob for use
2911        # in port actions (e.g. clean).
2912        if {[string length $portversion]} {
2913            set options(ports_version_glob) $portversion
2914        }
2915        if {[catch {set workername [mportopen $porturl [array get options] [array get variations]]} result]} {
2916            global errorInfo
2917            ui_debug "$errorInfo"
2918            break_softcontinue "Unable to open port: $result" 1 status
2919        }
2920        if {[catch {set result [mportexec $workername $target]} result]} {
2921            global errorInfo
2922            mportclose $workername
2923            ui_debug "$errorInfo"
2924            break_softcontinue "Unable to execute port: $result" 1 status
2925        }
2926
2927        mportclose $workername
2928       
2929        # start gsoc08-privileges
2930        if { [geteuid] != 0 && $result == 2} {
2931            # mportexec will return an error result code 2 if eval_targets fails due to insufficient privileges.
2932
2933            set portbinary "${macports::prefix}/bin/port"
2934
2935            ui_info "Attempting port action with 'sudo port': 'sudo $portbinary $target $portname'."
2936            set result 0
2937            if {[catch {set sudomsgs [exec sudo $portbinary $target $portname]} sudomsgs]} {
2938                global errorInfo
2939                ui_debug "$errorInfo"
2940                break_softcontinue "Unable to execute port: $errorInfo" 1 status
2941            }
2942
2943            ui_msg $sudomsgs
2944            ui_debug "'sudo $portbinary $target $portname' has completed."
2945        }
2946        # end gsoc08-privileges
2947       
2948        # Process any error that wasn't thrown and handled already
2949        if {$result} {
2950            break_softcontinue "Status $result encountered during processing." 1 status
2951        }
2952    }
2953   
2954    return $status
2955}
2956
2957
2958proc action_exit { action portlist opts } {
2959    # Return a semaphore telling the main loop to quit
2960    return -999
2961}
2962
2963
2964##########################################
2965# Command Parsing
2966##########################################
2967proc moreargs {} {
2968    global cmd_argn cmd_argc
2969    return [expr {$cmd_argn < $cmd_argc}]
2970}
2971
2972
2973proc lookahead {} {
2974    global cmd_argn cmd_argc cmd_argv
2975    if {$cmd_argn < $cmd_argc} {
2976        return [lindex $cmd_argv $cmd_argn]
2977    } else {
2978        return _EOF_
2979    }
2980}
2981
2982
2983proc advance {} {
2984    global cmd_argn
2985    incr cmd_argn
2986}
2987
2988
2989proc match s {
2990    if {[lookahead] == $s} {
2991        advance
2992        return 1
2993    }
2994    return 0
2995}
2996
2997# action_array specifies which action to run on the given command
2998# and if the action wants an expanded portlist.
2999# The value is a list of the form {action expand},
3000# where action is a string and expand a value:
3001#   0 none        Does not expect any text argument
3002#   1 strings     Expects some strings as text argument
3003#   2 ports       Wants an expanded list of ports as text argument
3004# Use action_args_const to translate them
3005global action_array
3006proc action_args_const {arg} {
3007    switch -- $arg {
3008        none {
3009            return 0
3010        }
3011        strings {
3012            return 1
3013        }
3014        default -
3015        ports {
3016            return 2
3017        }
3018    }
3019}
3020array set action_array [list \
3021    usage       [list action_usage          [action_args_const strings]] \
3022    help        [list action_help           [action_args_const strings]] \
3023    \
3024    echo        [list action_echo           [action_args_const ports]] \
3025    \
3026    info        [list action_info           [action_args_const ports]] \
3027    location    [list action_location       [action_args_const ports]] \
3028    notes       [list action_notes          [action_args_const ports]] \
3029    provides    [list action_provides       [action_args_const strings]] \
3030    log         [list action_log            [action_args_const ports]] \
3031    \
3032    activate    [list action_activate       [action_args_const ports]] \
3033    deactivate  [list action_deactivate     [action_args_const ports]] \
3034    \
3035    select      [list action_select         [action_args_const strings]] \
3036    \
3037    sync        [list action_sync           [action_args_const none]] \
3038    selfupdate  [list action_selfupdate     [action_args_const none]] \
3039    \
3040    upgrade     [list action_upgrade        [action_args_const ports]] \
3041    \
3042    version     [list action_version        [action_args_const none]] \
3043    platform    [list action_platform       [action_args_const none]] \
3044    compact     [list action_compact        [action_args_const ports]] \
3045    uncompact   [list action_uncompact      [action_args_const ports]] \
3046    \
3047    uninstall   [list action_uninstall      [action_args_const ports]] \
3048    \
3049    installed   [list action_installed      [action_args_const ports]] \
3050    outdated    [list action_outdated       [action_args_const ports]] \
3051    contents    [list action_contents       [action_args_const ports]] \
3052    dependents  [list action_dependents     [action_args_const ports]] \
3053    deps        [list action_info           [action_args_const ports]] \
3054    variants    [list action_variants       [action_args_const ports]] \
3055    \
3056    search      [list action_search         [action_args_const strings]] \
3057    list        [list action_list           [action_args_const ports]] \
3058    \
3059    ed          [list action_portcmds       [action_args_const ports]] \
3060    edit        [list action_portcmds       [action_args_const ports]] \
3061    cat         [list action_portcmds       [action_args_const ports]] \
3062    dir         [list action_portcmds       [action_args_const ports]] \
3063    work        [list action_portcmds       [action_args_const ports]] \
3064    cd          [list action_portcmds       [action_args_const ports]] \
3065    url         [list action_portcmds       [action_args_const ports]] \
3066    file        [list action_portcmds       [action_args_const ports]] \
3067    gohome      [list action_portcmds       [action_args_const ports]] \
3068    \
3069    fetch       [list action_target         [action_args_const ports]] \
3070    checksum    [list action_target         [action_args_const ports]] \
3071    extract     [list action_target         [action_args_const ports]] \
3072    patch       [list action_target         [action_args_const ports]] \
3073    configure   [list action_target         [action_args_const ports]] \
3074    build       [list action_target         [action_args_const ports]] \
3075    destroot    [list action_target         [action_args_const ports]] \
3076    install     [list action_target         [action_args_const ports]] \
3077    clean       [list action_target         [action_args_const ports]] \
3078    test        [list action_target         [action_args_const ports]] \
3079    lint        [list action_target         [action_args_const ports]] \
3080    submit      [list action_target         [action_args_const ports]] \
3081    trace       [list action_target         [action_args_const ports]] \
3082    livecheck   [list action_target         [action_args_const ports]] \
3083    distcheck   [list action_target         [action_args_const ports]] \
3084    mirror      [list action_target         [action_args_const ports]] \
3085    load        [list action_target         [action_args_const ports]] \
3086    unload      [list action_target         [action_args_const ports]] \
3087    distfiles   [list action_target         [action_args_const ports]] \
3088    \
3089    archive     [list action_target         [action_args_const ports]] \
3090    unarchive   [list action_target         [action_args_const ports]] \
3091    dmg         [list action_target         [action_args_const ports]] \
3092    mdmg        [list action_target         [action_args_const ports]] \
3093    dpkg        [list action_target         [action_args_const ports]] \
3094    mpkg        [list action_target         [action_args_const ports]] \
3095    pkg         [list action_target         [action_args_const ports]] \
3096    portpkg     [list action_target         [action_args_const ports]] \
3097    rpm         [list action_target         [action_args_const ports]] \
3098    srpm        [list action_target         [action_args_const ports]] \
3099    \
3100    quit        [list action_exit           [action_args_const none]] \
3101    exit        [list action_exit           [action_args_const none]] \
3102]
3103
3104proc find_action_proc { action } {
3105    global action_array
3106   
3107    set action_proc ""
3108    if { [info exists action_array($action)] } {
3109        set action_proc [lindex $action_array($action) 0]
3110    }
3111   
3112    return $action_proc
3113}
3114
3115# Returns whether an action expects text arguments at all,
3116# expects text arguments or wants an expanded list of ports
3117# Return value:
3118#   0 none        Does not expect any text argument
3119#   1 strings     Expects some strings as text argument
3120#   2 ports       Wants an expanded list of ports as text argument
3121# Use action_args_const to translate them
3122proc action_needs_portlist { action } {
3123    global action_array
3124
3125    set ret 0
3126    if {[info exists action_array($action)]} {
3127        set ret [lindex $action_array($action) 1]
3128    }
3129
3130    return $ret
3131}
3132
3133# cmd_opts_array specifies which arguments the commands accept
3134# Commands not listed here do not accept any arguments
3135# Syntax if {option argn}
3136# Where option is the name of the option and argn specifies how many arguments
3137# this argument takes
3138global cmd_opts_array
3139array set cmd_opts_array {
3140    edit        {{editor 1}}
3141    ed          {{editor 1}}
3142    info        {category categories depends_build depends_lib depends_run
3143                 depends description epoch fullname heading homepage index license
3144                 line long_description
3145                 maintainer maintainers name platform platforms portdir pretty
3146                 revision variant variants version}
3147    search      {case-sensitive category categories 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.