source: trunk/base/src/port1.0/portutil.tcl @ 106614

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

combine multiple adjacent calls to global

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 101.7 KB
Line 
1# -*- 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
2# $Id: portutil.tcl 106614 2013-06-01 05:12:02Z jmr@macports.org $
3#
4# Copyright (c) 2002-2003 Apple Inc.
5# Copyright (c) 2004 Robert Shaw <rshaw@opendarwin.org>
6# Copyright (c) 2006-2007 Markus W. Weissmann <mww@macports.org>
7# Copyright (c) 2004-2013 The MacPorts Project
8# All rights reserved.
9#
10# Redistribution and use in source and binary forms, with or without
11# modification, are permitted provided that the following conditions
12# are met:
13# 1. Redistributions of source code must retain the above copyright
14#    notice, this list of conditions and the following disclaimer.
15# 2. Redistributions in binary form must reproduce the above copyright
16#    notice, this list of conditions and the following disclaimer in the
17#    documentation and/or other materials provided with the distribution.
18# 3. Neither the name of Apple Inc. nor the names of its contributors
19#    may be used to endorse or promote products derived from this software
20#    without specific prior written permission.
21#
22# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
23# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
24# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
25# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
26# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
27# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
28# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
29# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
30# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
31# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
32# POSSIBILITY OF SUCH DAMAGE.
33#
34
35package provide portutil 1.0
36package require Pextlib 1.0
37package require macports_dlist 1.0
38package require macports_util 1.0
39package require msgcat
40package require porttrace 1.0
41
42global targets target_uniqid all_variants
43
44set targets [list]
45set target_uniqid 0
46
47set all_variants [list]
48
49########### External High Level Procedures ###########
50
51namespace eval options {
52}
53
54# option
55# This is an accessor for Portfile options.  Targets may use
56# this in the same style as the standard Tcl "set" procedure.
57#   option  - the name of the option to read or write
58#       not called 'name' because this would fail if its value was 'name'...
59#   value - an optional value to assign to the option
60
61proc option {option args} {
62    # XXX: right now we just transparently use globals
63    # eventually this will need to bridge the options between
64    # the Portfile's interpreter and the target's interpreters.
65    global $option
66    if {[llength $args] > 0} {
67        ui_debug "setting option $option to $args"
68        set $option [lindex $args 0]
69    }
70    return [set $option]
71}
72
73# exists
74# This is an accessor for Portfile options.  Targets may use
75# this procedure to test for the existence of a Portfile option.
76#   option - the name of the option to test for existence
77
78proc exists {option} {
79    # XXX: right now we just transparently use globals
80    # eventually this will need to bridge the options between
81    # the Portfile's interpreter and the target's interpreters.
82    global $option
83    return [info exists $option]
84}
85
86##
87# Handle an option
88#
89# @param option name of the option
90# @param args arguments
91proc handle_option {option args} {
92    global $option user_options option_procs
93
94    if {![info exists user_options($option)]} {
95        set $option $args
96    }
97}
98
99##
100# Handle option-append
101#
102# @param option name of the option
103# @param args arguments
104proc handle_option-append {option args} {
105    global $option user_options option_procs
106
107    if {![info exists user_options($option)]} {
108        if {[info exists $option]} {
109            set $option [concat [set $option] $args]
110        } else {
111            set $option $args
112        }
113    }
114}
115
116##
117# Handle option-delete
118#
119# @param option name of the option
120# @param args arguments
121proc handle_option-delete {option args} {
122    global $option user_options option_procs
123
124    if {![info exists user_options($option)] && [info exists $option]} {
125        set temp [set $option]
126        foreach val $args {
127            set temp [ldelete $temp $val]
128        }
129        set $option $temp
130    }
131}
132
133##
134# Handle option-strsed
135#
136# @param option name of the option
137# @param args arguments
138proc handle_option-strsed {option args} {
139    global $option user_options option_procs
140
141    if {![info exists user_options($option)] && [info exists $option]} {
142        set temp [set $option]
143        foreach val $args {
144            set temp [strsed $temp $val]
145        }
146        set $option $temp
147    }
148}
149
150##
151# Handle option-replace
152#
153# @param option name of the option
154# @param args arguments
155proc handle_option-replace {option args} {
156    global $option user_options option_procs deprecated_options
157
158    # Deprecate -replace with only one argument, for backwards compatibility call -strsed
159    # XXX: Remove this in 2.2.0
160    if {[llength $args] == 1} {
161        if {![info exists deprecated_options(${option}-replace)]} {
162            set deprecated_options(${option}-replace) [list ${option}-strsed 0]
163        }
164        set refcount [lindex $deprecated_options(${option}-replace) 1]
165        lset deprecated_options(${option}-replace) 1 [expr $refcount + 1]
166        return [eval handle_option-strsed $option $args]
167    }
168
169    if {![info exists user_options($option)] && [info exists $option]} {
170        foreach {old new} $args {
171            set index [lsearch -exact [set $option] $old]
172            if {$index == -1} {
173                continue
174            }
175            set $option [lreplace [set $option] $index $index $new]
176        }
177    }
178}
179
180# options
181# Exports options in an array as externally callable procedures
182# Thus, "options name date" would create procedures named "name"
183# and "date" that set global variables "name" and "date", respectively
184# When an option is modified in any way, options::$option is called,
185# if it exists
186# Arguments: <list of options>
187proc options {args} {
188    foreach option $args {
189        interp alias {} $option {} handle_option $option
190        interp alias {} $option-append {} handle_option-append $option
191        interp alias {} $option-delete {} handle_option-delete $option
192        interp alias {} $option-strsed {} handle_option-strsed $option
193        interp alias {} $option-replace {} handle_option-replace $option
194    }
195}
196
197##
198# Export options into PortInfo
199#
200# @param option the name of the option
201# @param action set or delete
202# @param value the value to be set, defaults to an empty string
203proc options::export {option action {value ""}} {
204    global $option PortInfo
205    switch $action {
206        set {
207            set PortInfo($option) $value
208        }
209        delete {
210            unset -nocomplain PortInfo($option)
211        }
212    }
213}
214
215##
216# Export multiple options
217#
218# @param args list of ports to be exported
219proc options_export {args} {
220    foreach option $args {
221        option_proc $option options::export
222    }
223}
224
225##
226# Print a warning for deprecated options
227#
228# @param option deprecated option
229# @param action read/set
230# @param value ignored
231proc handle_deprecated_option {option action {value ""}} {
232    global subport $option deprecated_options
233    set newoption [lindex $deprecated_options($option) 0]
234    set refcount  [lindex $deprecated_options($option) 1]
235    global $newoption
236
237    if {$newoption == ""} {
238        ui_warn "Port $subport using deprecated option \"$option\"."
239        return
240    }
241
242    # Increment reference counter
243    lset deprecated_options($option) 1 [expr $refcount + 1]
244
245    if {$action != "read"} {
246        $newoption [set $option]
247    } else {
248        $option [set $newoption]
249    }
250}
251
252##
253# Get the name of the array containing the deprecated options
254# Thin layer avoiding to share global variables without notice
255proc get_deprecated_options {} {
256    return "deprecated_options"
257}
258
259##
260# Mark an option as deprecated
261# If it is set or accessed, it will be mapped to the new option
262#
263# @param option name of the option
264# @param newoption name of a superseding option
265proc option_deprecate {option {newoption ""} } {
266    global deprecated_options
267    # If a new option is specified, default the option to $newoption
268    set deprecated_options($option) [list $newoption 0]
269    # Create a normal option for compatibility
270    options $option
271    # Register a proc for handling the deprecation
272    option_proc $option handle_deprecated_option
273}
274
275##
276# Registers a proc to be called when an option is changed
277#
278# @param option the name of the option
279# @param args name of procs
280proc option_proc {option args} {
281    global option_procs $option
282    if {[info exists option_procs($option)]} {
283        set option_procs($option) [concat $option_procs($option) $args]
284        # we're already tracing
285    } else {
286        set option_procs($option) $args
287        trace add variable $option {read write unset} option_proc_trace
288    }
289}
290
291# option_proc_trace
292# trace handler for option reads. Calls option procedures with correct arguments.
293proc option_proc_trace {optionName index op} {
294    global option_procs
295    upvar $optionName $optionName
296    switch $op {
297        write {
298            foreach p $option_procs($optionName) {
299                $p $optionName set [set $optionName]
300            }
301        }
302        read {
303            foreach p $option_procs($optionName) {
304                $p $optionName read
305            }
306        }
307        unset {
308            foreach p $option_procs($optionName) {
309                if {[catch {$p $optionName delete} result]} {
310                    ui_debug "error during unset trace ($p): $result\n$::errorInfo"
311                }
312            }
313            trace add variable $optionName {read write unset} option_proc_trace
314        }
315    }
316}
317
318# commands
319# Accepts a list of arguments, of which several options are created
320# and used to form a standard set of command options.
321proc commands {args} {
322    foreach option $args {
323        options use_${option} ${option}.dir ${option}.pre_args ${option}.args ${option}.post_args ${option}.env ${option}.nice ${option}.type ${option}.cmd
324    }
325}
326
327# Given a command name, assemble a command string
328# composed of the command options.
329proc command_string {command} {
330    global ${command}.dir ${command}.pre_args ${command}.args ${command}.post_args ${command}.cmd
331
332    if {[info exists ${command}.dir]} {
333        append cmdstring "cd \"[set ${command}.dir]\" &&"
334    }
335
336    if {[info exists ${command}.cmd]} {
337        foreach string [set ${command}.cmd] {
338            append cmdstring " $string"
339        }
340    } else {
341        append cmdstring " ${command}"
342    }
343
344    foreach var "${command}.pre_args ${command}.args ${command}.post_args" {
345        if {[info exists $var]} {
346            foreach string [set ${var}] {
347                append cmdstring " ${string}"
348            }
349        }
350    }
351
352    ui_debug "Assembled command: '$cmdstring'"
353    return $cmdstring
354}
355
356# Given a command name, execute it with the options.
357# command_exec command [-notty] [-varprefix variable_prefix] [command_prefix [command_suffix]]
358# command           name of the command
359# variable_prefix   name of the variable prefix to use (defaults to command)
360# command_prefix    additional command prefix (typically pipe command)
361# command_suffix    additional command suffix (typically redirection)
362proc command_exec {command args} {
363    set varprefix "${command}"
364    set notty ""
365    set command_prefix ""
366    set command_suffix ""
367
368    if {[llength $args] > 0} {
369        if {[lindex $args 0] == "-notty"} {
370            set notty "-notty"
371            set args [lrange $args 1 end]
372        }
373
374        if {[lindex $args 0] == "-varprefix"} {
375            set varprefix [lindex $args 1]
376            set args [lrange $args 2 end]
377        }
378
379        if {[llength $args] > 0} {
380            set command_prefix [lindex $args 0]
381            if {[llength $args] > 1} {
382                set command_suffix [lindex $args 1]
383            }
384        }
385    }
386
387    global ${varprefix}.env ${varprefix}.env_array ${varprefix}.nice env macosx_version
388
389    # Set the environment.
390    # If the array doesn't exist, we create it with the value
391    # coming from ${varprefix}.env
392    # Otherwise, it means the caller actually played with the environment
393    # array already (e.g. configure flags).
394    if {![array exists ${varprefix}.env_array]} {
395        parse_environment ${varprefix}
396    }
397    if {[option macosx_deployment_target] ne ""} {
398        set ${varprefix}.env_array(MACOSX_DEPLOYMENT_TARGET) [option macosx_deployment_target]
399    }
400    set ${varprefix}.env_array(CC_PRINT_OPTIONS) "YES"
401    set ${varprefix}.env_array(CC_PRINT_OPTIONS_FILE) [file join [option workpath] ".CC_PRINT_OPTIONS"]
402    if {[option compiler.cpath] ne ""} {
403        set ${varprefix}.env_array(CPATH) [join [option compiler.cpath] :]
404    }
405    if {[option compiler.library_path] ne ""} {
406        set ${varprefix}.env_array(LIBRARY_PATH) [join [option compiler.library_path] :]
407    }
408
409    # Debug that.
410    ui_debug "Environment: [environment_array_to_string ${varprefix}.env_array]"
411
412    # Prepare nice value change
413    set nice ""
414    if {[info exists ${varprefix}.nice] && [set ${varprefix}.nice] != ""} {
415        set nice "-nice [set ${varprefix}.nice]"
416    }
417
418    # Get the command string.
419    set cmdstring [command_string ${command}]
420
421    # Call this command.
422    # TODO: move that to the system native call?
423    # Save the environment.
424    array set saved_env [array get env]
425    # Set the overriden variables from the portfile.
426    array set env [array get ${varprefix}.env_array]
427    # Call the command.
428    set fullcmdstring "$command_prefix $cmdstring $command_suffix"
429    ui_debug "Executing command line: $fullcmdstring"
430    set code [catch {eval system $notty $nice \$fullcmdstring} result]
431    # Save variables in order to re-throw the same error code.
432    set errcode $::errorCode
433    set errinfo $::errorInfo
434
435    # Unset the command array until next time.
436    array unset ${varprefix}.env_array
437
438    # Restore the environment.
439    array unset env *
440    if {$macosx_version == "10.5"} {
441        unsetenv *
442    }
443    array set env [array get saved_env]
444
445    # Return as if system had been called directly.
446    return -code $code -errorcode $errcode -errorinfo $errinfo $result
447}
448
449# default
450# Sets a variable to the supplied default if it does not exist,
451# and adds a variable trace. The variable traces allows for delayed
452# variable and command expansion in the variable's default value.
453proc default {option val} {
454    global $option option_defaults
455    if {[info exists option_defaults($option)]} {
456        ui_debug "Re-registering default for $option"
457        # remove the old trace
458        trace vdelete $option rwu default_check
459    } else {
460        # If option is already set and we did not set it
461        # do not reset the value
462        if {[info exists $option]} {
463            return
464        }
465    }
466    set option_defaults($option) $val
467    set $option $val
468    trace variable $option rwu default_check
469}
470
471# default_check
472# trace handler to provide delayed variable & command expansion
473# for default variable values
474proc default_check {optionName index op} {
475    global option_defaults $optionName
476    switch $op {
477        w {
478            unset option_defaults($optionName)
479            trace vdelete $optionName rwu default_check
480            return
481        }
482        r {
483            upvar $optionName option
484            uplevel #0 set $optionName $option_defaults($optionName)
485            return
486        }
487        u {
488            unset option_defaults($optionName)
489            trace vdelete $optionName rwu default_check
490            return
491        }
492    }
493}
494
495##
496# Filter options which take strings removing indent to ease Portfile writing
497proc handle_option_string {option action args} {
498    global $option
499
500    switch $action {
501        set {
502            set args [join $args]
503
504            set fulllist {}
505            # args is a list of strings/list
506            foreach arg $args {
507                # Strip trailing empty lines
508                if {[string index $arg 0] == "\n"} {
509                    set arg [string range $arg 1 end]
510                }
511                if {[string index $arg end] == "\n"} {
512                    set arg [string range $arg 0 end-1]
513                }
514
515                # Determine indent level
516                set indent ""
517                for {set i 0} {$i < [string length $arg]} {incr i} {
518                    set c [string index $arg $i]
519                    if {$c != " " && $c != "\t"} {
520                        break
521                    }
522                    append indent $c
523                }
524                # Remove indent on first line
525                set arg [string replace $arg 0 [expr $i - 1]]
526                # Remove indent on each other line
527                set arg [string map "\"\n$indent\" \"\n\"" $arg]
528
529                lappend fulllist $arg
530            }
531
532            set $option $fulllist
533        }
534    }
535}
536
537# variant <provides> [<provides> ...] [requires <requires> [<requires>]]
538# Portfile level procedure to provide support for declaring variants
539proc variant {args} {
540    global all_variants PortInfo porturl
541
542    # Each key in PortInfo(vinfo) maps to an array which contains the
543    # following keys:
544    #   * conflicts
545    #   * description: This key's mapping is duplicated in
546    #                  PortInfo(variant_desc) for backward compatibility
547    #                  reasons (specifically 1.7.0's format of PortIndex).
548    #   * is_default: This key exists iff the variant is a default variant.
549    #   * requires
550    if {![info exists PortInfo(vinfo)]} {
551        set PortInfo(vinfo) {}
552    }
553    array set vinfo $PortInfo(vinfo)
554
555    set len [llength $args]
556    if {$len < 2} {
557        return -code error "Malformed variant specification"
558    }
559    set code [lindex $args end]
560    set args [lrange $args 0 [expr $len - 2]]
561
562    set ditem [variant_new "temp-variant"]
563
564    # mode indicates what the arg is interpreted as.
565    # possible mode keywords are: requires, conflicts, provides
566    # The default mode is provides.  Arguments are added to the
567    # most recently specified mode (left to right).
568    set mode "provides"
569    foreach arg $args {
570        switch -exact $arg {
571            description -
572            provides -
573            requires -
574            conflicts { set mode $arg }
575            default { ditem_append $ditem $mode $arg }
576        }
577    }
578    ditem_key $ditem name "[join [ditem_key $ditem provides] -]"
579
580    # make a user procedure named variant-blah-blah
581    # we will call this procedure during variant-run
582    makeuserproc "variant-[ditem_key $ditem name]" \{$code\}
583
584    # Export provided variant to PortInfo
585    # (don't list it twice if the variant was already defined, which can happen
586    # with universal or group code).
587    set variant_provides [ditem_key $ditem provides]
588    if {[variant_exists $variant_provides]} {
589        # This variant was already defined. Remove it from the dlist.
590        variant_remove_ditem $variant_provides
591    } else {
592        # Create an array to contain the variant's information.
593        if {![info exists vinfo($variant_provides)]} {
594            set vinfo($variant_provides) {}
595        }
596        array set variant $vinfo($variant_provides)
597
598        # Set conflicts.
599        set vconflicts [join [lsort [ditem_key $ditem conflicts]]]
600        if {$vconflicts ne ""} {
601            array set variant [list conflicts $vconflicts]
602        }
603
604        lappend PortInfo(variants) $variant_provides
605        set vdesc [join [ditem_key $ditem description]]
606
607        # read global variant description, if none given
608        if {$vdesc == ""} {
609            set vdesc [variant_desc $porturl $variant_provides]
610        }
611
612        # Set description.
613        if {$vdesc ne ""} {
614            array set variant [list description $vdesc]
615            # XXX: The following line should be removed after 1.8.0 is
616            #      released.
617            lappend PortInfo(variant_desc) $variant_provides $vdesc
618        }
619
620        # Set requires.
621        set vrequires [join [lsort [ditem_key $ditem requires]]]
622        if {$vrequires ne ""} {
623            array set variant [list requires $vrequires]
624        }
625    }
626
627    # Add the variant (back) to PortInfo(vinfo).
628    array set vinfo [list $variant_provides [array get variant]]
629    set PortInfo(vinfo) [array get vinfo]
630
631    if {[variant_isset $variant_provides]} {
632        # set variants that this one requires
633        foreach req [ditem_key $ditem requires] {
634            variant_set $req
635        }
636    }
637
638    # Finally append the ditem to the dlist.
639    lappend all_variants $ditem
640}
641
642# variant_isset name
643# Returns 1 if variant name selected, otherwise 0
644proc variant_isset {name} {
645    global variations
646
647    if {[info exists variations($name)] && $variations($name) == "+"} {
648        return 1
649    }
650    return 0
651}
652
653# variant_set name
654# Sets variant to run for current portfile
655proc variant_set {name} {
656    global variations
657    set variations($name) +
658}
659
660# variant_remove_ditem name
661# Remove variant name's ditem from the all_variants dlist
662proc variant_remove_ditem {name} {
663    global all_variants
664    set item_index 0
665    foreach variant_item $all_variants {
666        set item_provides [ditem_key $variant_item provides]
667        if {$item_provides == $name} {
668            set all_variants [lreplace $all_variants $item_index $item_index]
669            break
670        }
671
672        incr item_index
673    }
674}
675
676# variant_exists name
677# determine if a variant exists.
678proc variant_exists {name} {
679    global PortInfo
680    if {[info exists PortInfo(variants)] &&
681      [lsearch -exact $PortInfo(variants) $name] >= 0} {
682        return 1
683    }
684
685    return 0
686}
687
688##
689# Load the global description file for a port tree
690#
691# @param descfile path to the descriptions file
692proc load_variant_desc_file {descfile} {
693    global variant_descs_global
694
695    if {![info exists variant_descs_global($descfile)]} {
696        set variant_descs_global($descfile) yes
697
698        if {[file exists $descfile]} {
699            ui_debug "Reading variant descriptions from $descfile"
700
701            if {[catch {set fd [open $descfile r]} err]} {
702                ui_warn "Could not open global variant description file: $err"
703                return ""
704            }
705            set lineno 0
706            while {[gets $fd line] >= 0} {
707                incr lineno
708                set name [lindex $line 0]
709                set desc [lindex $line 1]
710                if {$name != "" && $desc != ""} {
711                    set variant_descs_global(${descfile}_$name) $desc
712                } else {
713                    ui_warn "Invalid variant description in $descfile at line $lineno"
714                }
715            }
716            close $fd
717        }
718    }
719}
720
721##
722# Get description for a variant from global descriptions file
723#
724# @param porturl url to a port
725# @param variant name
726# @return description from descriptions file or an empty string
727proc variant_desc {porturl variant} {
728    global variant_descs_global
729
730    set descfile [getportresourcepath $porturl "port1.0/variant_descriptions.conf" no]
731    load_variant_desc_file $descfile
732
733    if {[info exists variant_descs_global(${descfile}_${variant})]} {
734        return $variant_descs_global(${descfile}_${variant})
735    } else {
736        set descfile [getdefaultportresourcepath "port1.0/variant_descriptions.conf"]
737        load_variant_desc_file $descfile
738
739        if {[info exists variant_descs_global(${descfile}_${variant})]} {
740            return $variant_descs_global(${descfile}_${variant})
741        }
742
743        return ""
744    }
745}
746
747# platform [<os> [<release>]] [<arch>]
748# Portfile level procedure to provide support for declaring platform-specifics
749# Basically, just a fancy 'if', so that Portfiles' platform declarations can
750# be more readable, and support arch and version specifics
751proc platform {args} {
752    global os.platform os.subplatform os.arch os.major
753
754    set len [llength $args]
755    if {$len < 2} {
756        return -code error "Malformed platform specification"
757    }
758    set code [lindex $args end]
759    set os [lindex $args 0]
760    set args [lrange $args 1 [expr $len - 2]]
761
762    foreach arg $args {
763        if {[regexp {(^[0-9]+$)} $arg match result]} {
764            set release $result
765        } elseif {[regexp {([a-zA-Z0-9]*)} $arg match result]} {
766            set arch $result
767        }
768    }
769
770    set match 0
771    # 'os' could be a platform or an arch when it's alone
772    if {$len == 2 && ($os == ${os.platform} || $os == ${os.subplatform} || $os == ${os.arch})} {
773        set match 1
774    } elseif {($os == ${os.platform} || $os == ${os.subplatform})
775              && (![info exists release] || ${os.major} == $release)
776              && (![info exists arch] || ${os.arch} == $arch)} {
777        set match 1
778    }
779
780    # Execute the code if this platform matches the platform we're on
781    if {$match} {
782        uplevel 1 $code
783    }
784}
785
786# Portfiles may define more than one port.
787# This executes the given code in 'body' if we were opened as the specified
788# subport, and also adds it to the list of subports that are defined.
789proc subport {subname body} {
790    global subport name PortInfo
791    if {$subport == $name && $subname != $name && 
792        (![info exists PortInfo(subports)] || [lsearch -exact $PortInfo(subports) $subname] == -1)} {
793        lappend PortInfo(subports) $subname
794    }
795    if {[string equal -nocase $subname $subport]} {
796        set PortInfo(name) $subname
797        uplevel 1 $body
798    }
799}
800
801########### Environment utility functions ###########
802
803# Parse the environment string of a command, storing the values into the
804# associated environment array.
805proc parse_environment {command} {
806    global ${command}.env ${command}.env_array
807
808    if {[info exists ${command}.env]} {
809        # Flatten the environment string.
810        set the_environment [join [set ${command}.env]]
811
812        while {[regexp "^(?: *)(\[^= \]+)=(\"|'|)(\[^\"'\]*?)\\2(?: +|$)(.*)$" ${the_environment} matchVar key delimiter value remaining]} {
813            set the_environment ${remaining}
814            set ${command}.env_array(${key}) ${value}
815        }
816    } else {
817        array set ${command}.env_array {}
818    }
819}
820
821# Append to the value in the parsed environment.
822# Leave the environment untouched if the value is empty.
823proc append_to_environment_value {command key value} {
824    global ${command}.env_array
825
826    if {[string length $value] == 0} {
827        return
828    }
829
830    # Parse out any delimiter.
831    set append_value $value
832    if {[regexp {^("|')(.*)\1$} $append_value matchVar append_delim matchedValue]} {
833        set append_value $matchedValue
834    }
835
836    if {[info exists ${command}.env_array($key)]} {
837        set original_value [set ${command}.env_array($key)]
838        set ${command}.env_array($key) "${original_value} ${append_value}"
839    } else {
840        set ${command}.env_array($key) $append_value
841    }
842}
843
844# Append several items to a value in the parsed environment.
845proc append_list_to_environment_value {command key vallist} {
846    foreach {value} $vallist {
847        append_to_environment_value ${command} $key $value
848    }
849}
850
851# Build the environment as a string.
852# Remark: this method is only used for debugging purposes.
853proc environment_array_to_string {environment_array} {
854    upvar 1 ${environment_array} env_array
855
856    set theString ""
857    foreach {key value} [array get env_array] {
858        if {$theString == ""} {
859            set theString "$key='$value'"
860        } else {
861            set theString "${theString} $key='$value'"
862        }
863    }
864
865    return $theString
866}
867
868########### Distname utility functions ###########
869
870# Given a distribution file name, return the appended tag
871# Example: getdisttag distfile.tar.gz:tag1 returns "tag1"
872# / isn't included in the regexp, thus allowing port specification in URLs.
873proc getdisttag {name} {
874    if {[regexp {.+:([0-9A-Za-z_-]+)$} $name match tag]} {
875        return $tag
876    } else {
877        return ""
878    }
879}
880
881# Given a distribution file name, return the name without an attached tag
882# Example : getdistname distfile.tar.gz:tag1 returns "distfile.tar.gz"
883# / isn't included in the regexp, thus allowing port specification in URLs.
884proc getdistname {name} {
885    regexp {(.+):[0-9A-Za-z_-]+$} $name match name
886    return $name
887}
888
889########### Misc Utility Functions ###########
890
891# tbool (testbool)
892# If the variable exists in the calling procedure's namespace
893# and is set to "yes", return 1. Otherwise, return 0
894proc tbool {key} {
895    upvar $key $key
896    if {[info exists $key]} {
897        if {[string equal -nocase [set $key] "yes"]} {
898            return 1
899        }
900    }
901    return 0
902}
903
904# ldelete
905# Deletes a value from the supplied list
906proc ldelete {list value} {
907    set ix [lsearch -exact $list $value]
908    if {$ix >= 0} {
909        return [lreplace $list $ix $ix]
910    }
911    return $list
912}
913
914# reinplace
915# Provides "sed in place" functionality
916proc reinplace {args}  {
917    global env worksrcpath macosx_version
918    set extended 0
919    set suppress 0
920    set oldlocale_exists 0
921    set oldlocale ""
922    set locale ""
923    set dir ${worksrcpath}
924    while 1 {
925        set arg [lindex $args 0]
926        if {[string index $arg 0] eq "-"} {
927            set args [lrange $args 1 end]
928            switch -- [string range $arg 1 end] {
929                locale {
930                    set oldlocale_exists [info exists env(LC_CTYPE)]
931                    if {$oldlocale_exists} {
932                        set oldlocale $env(LC_CTYPE)
933                    }
934                    set locale [lindex $args 0]
935                    set args [lrange $args 1 end]
936                }
937                E {
938                    set extended 1
939                }
940                n {
941                    set suppress 1
942                }
943                W {
944                    set dir [lindex $args 0]
945                    set args [lrange $args 1 end]
946                }
947                - {
948                    break
949                }
950                default {
951                    error "reinplace: unknown flag '$arg'"
952                }
953            }
954        } else {
955            break
956        }
957    }
958    if {[llength $args] < 2} {
959        error "reinplace ?-E? ?-n? ?-W dir? pattern file ..."
960    }
961    set pattern [lindex $args 0]
962    set files [lrange $args 1 end]
963
964    foreach file $files {
965        # if $file is an absolute path already, file join will just return the
966        # absolute path, otherwise it is $dir/$file
967        set file [file join $dir $file]
968
969        if {[catch {set tmpfile [mkstemp "/tmp/[file tail $file].sed.XXXXXXXX"]} error]} {
970            global errorInfo
971            ui_debug "$errorInfo"
972            ui_error "reinplace: $error"
973            return -code error "reinplace failed"
974        } else {
975            # Extract the Tcl Channel number
976            set tmpfd [lindex $tmpfile 0]
977            # Set tmpfile to only the file name
978            set tmpfile [join [lrange $tmpfile 1 end]]
979        }
980
981        set cmdline $portutil::autoconf::sed_command
982        if {$extended} {
983            if {$portutil::autoconf::sed_ext_flag == "N/A"} {
984                ui_debug "sed extended regexp not available"
985                return -code error "reinplace sed(1) too old"
986            }
987            lappend cmdline $portutil::autoconf::sed_ext_flag
988        }
989        if {$suppress} {
990            lappend cmdline -n
991        }
992        set cmdline [concat $cmdline [list $pattern < $file >@ $tmpfd]]
993        if {$locale != ""} {
994            set env(LC_CTYPE) $locale
995        }
996        ui_debug "Executing reinplace: $cmdline"
997        if {[catch {eval exec $cmdline} error]} {
998            global errorInfo
999            ui_debug "$errorInfo"
1000            ui_error "reinplace: $error"
1001            file delete "$tmpfile"
1002            if {$locale != ""} {
1003                if {$oldlocale_exists} {
1004                    set env(LC_CTYPE) $oldlocale
1005                } else {
1006                    unset env(LC_CTYPE)
1007                    if {$macosx_version == "10.5"} {
1008                        unsetenv LC_CTYPE
1009                    }
1010                }
1011            }
1012            close $tmpfd
1013            return -code error "reinplace sed(1) failed"
1014        }
1015
1016        if {$locale != ""} {
1017            if {$oldlocale_exists} {
1018                set env(LC_CTYPE) $oldlocale
1019            } else {
1020                unset env(LC_CTYPE)
1021                if {$macosx_version == "10.5"} {
1022                    unsetenv LC_CTYPE
1023                }
1024            }
1025        }
1026        close $tmpfd
1027
1028        set attributes [file attributes $file]
1029        # start gsoc08-privileges
1030        chownAsRoot $file
1031        # end gsoc08-privileges
1032
1033        # We need to overwrite this file
1034        if {[catch {file attributes $file -permissions u+w} error]} {
1035            global errorInfo
1036            ui_debug "$errorInfo"
1037            ui_error "reinplace: $error"
1038            file delete "$tmpfile"
1039            return -code error "reinplace permissions failed"
1040        }
1041
1042        if {[catch {file copy -force $tmpfile $file} error]} {
1043            global errorInfo
1044            ui_debug "$errorInfo"
1045            ui_error "reinplace: $error"
1046            file delete "$tmpfile"
1047            return -code error "reinplace copy failed"
1048        }
1049
1050        fileAttrsAsRoot $file $attributes
1051
1052        file delete "$tmpfile"
1053    }
1054    return
1055}
1056
1057# delete
1058# file delete -force by itself doesn't handle directories properly
1059# on systems older than Tiger. Let's recurse using fs-traverse instead.
1060proc delete {args} {
1061    ui_debug "delete: $args"
1062    fs-traverse -depth file $args {
1063        file delete -force -- $file
1064        continue
1065    }
1066}
1067
1068# touch
1069# mimics the BSD touch command
1070proc touch {args} {
1071    while {[string match -* [lindex $args 0]]} {
1072        set arg [string range [lindex $args 0] 1 end]
1073        set args [lrange $args 1 end]
1074        switch -- $arg {
1075            a -
1076            c -
1077            m {set options($arg) yes}
1078            r -
1079            t {
1080                set narg [lindex $args 0]
1081                set args [lrange $args 1 end]
1082                if {[string length $narg] == 0} {
1083                    return -code error "touch: option requires an argument -- $arg"
1084                }
1085                set options($arg) $narg
1086                set options(rt) $arg ;# later option overrides earlier
1087            }
1088            - break
1089            default {return -code error "touch: illegal option -- $arg"}
1090        }
1091    }
1092
1093    # parse the r/t options
1094    if {[info exists options(rt)]} {
1095        if {[string equal $options(rt) r]} {
1096            # -r
1097            # get atime/mtime from the file
1098            if {[file exists $options(r)]} {
1099                set atime [file atime $options(r)]
1100                set mtime [file mtime $options(r)]
1101            } else {
1102                return -code error "touch: $options(r): No such file or directory"
1103            }
1104        } else {
1105            # -t
1106            # parse the time specification
1107            # turn it into a CCyymmdd hhmmss
1108            set timespec {^(?:(\d\d)?(\d\d))?(\d\d)(\d\d)(\d\d)(\d\d)(?:\.(\d\d))?$}
1109            if {[regexp $timespec $options(t) {} CC YY MM DD hh mm SS]} {
1110                if {[string length $YY] == 0} {
1111                    set year [clock format [clock seconds] -format %Y]
1112                } elseif {[string length $CC] == 0} {
1113                    if {$YY >= 69 && $YY <= 99} {
1114                        set year 19$YY
1115                    } else {
1116                        set year 20$YY
1117                    }
1118                } else {
1119                    set year $CC$YY
1120                }
1121                if {[string length $SS] == 0} {
1122                    set SS 00
1123                }
1124                set atime [clock scan "$year$MM$DD $hh$mm$SS"]
1125                set mtime $atime
1126            } else {
1127                return -code error \
1128                    {touch: out of range or illegal time specification: [[CC]YY]MMDDhhmm[.SS]}
1129            }
1130        }
1131    } else {
1132        set atime [clock seconds]
1133        set mtime [clock seconds]
1134    }
1135
1136    # do we have any files to process?
1137    if {[llength $args] == 0} {
1138        # print usage
1139        return -code error {usage: touch [-a] [-c] [-m] [-r file] [-t [[CC]YY]MMDDhhmm[.SS]] file ...}
1140    }
1141
1142    foreach file $args {
1143        if {![file exists $file]} {
1144            if {[info exists options(c)]} {
1145                continue
1146            } else {
1147                close [open $file w]
1148            }
1149        }
1150
1151        if {[info exists options(a)] || ![info exists options(m)]} {
1152            file atime $file $atime
1153        }
1154        if {[info exists options(m)] || ![info exists options(a)]} {
1155            file mtime $file $mtime
1156        }
1157    }
1158    return
1159}
1160
1161# copy
1162proc copy {args} {
1163    eval file copy $args
1164}
1165
1166# move
1167proc move {args} {
1168    eval file rename $args
1169}
1170
1171# ln
1172# Mimics the BSD ln implementation
1173# ln [-f] [-h] [-s] [-v] source_file [target_file]
1174# ln [-f] [-h] [-s] [-v] source_file ... target_dir
1175proc ln {args} {
1176    while {[string match -* [lindex $args 0]]} {
1177        set arg [string range [lindex $args 0] 1 end]
1178        if {[string length $arg] > 1} {
1179            set remainder -[string range $arg 1 end]
1180            set arg [string range $arg 0 0]
1181            set args [lreplace $args 0 0 $remainder]
1182        } else {
1183            set args [lreplace $args 0 0]
1184        }
1185        switch -- $arg {
1186            f -
1187            h -
1188            s -
1189            v {set options($arg) yes}
1190            - break
1191            default {return -code error "ln: illegal option -- $arg"}
1192        }
1193    }
1194
1195    if {[llength $args] == 0} {
1196        return -code error [join {{usage: ln [-f] [-h] [-s] [-v] source_file [target_file]}
1197                                  {       ln [-f] [-h] [-s] [-v] file ... directory}} "\n"]
1198    } elseif {[llength $args] == 1} {
1199        set files $args
1200        set target ./
1201    } else {
1202        set files [lrange $args 0 [expr [llength $args] - 2]]
1203        set target [lindex $args end]
1204    }
1205
1206    foreach file $files {
1207        if {[file isdirectory $file] && ![info exists options(s)]} {
1208            return -code error "ln: $file: Is a directory"
1209        }
1210
1211        if {[file isdirectory $target] && ([file type $target] ne "link" || ![info exists options(h)])} {
1212            set linktarget [file join $target [file tail $file]]
1213        } else {
1214            set linktarget $target
1215        }
1216
1217        if {![catch {file type $linktarget}]} {
1218            if {[info exists options(f)]} {
1219                file delete $linktarget
1220            } else {
1221                return -code error "ln: $linktarget: File exists"
1222            }
1223        }
1224
1225        if {[llength $files] > 2} {
1226            if {![file exists $linktarget]} {
1227                return -code error "ln: $linktarget: No such file or directory"
1228            } elseif {![file isdirectory $target]} {
1229                # this error isn't strictly what BSD ln gives, but I think it's more useful
1230                return -code error "ln: $target: Not a directory"
1231            }
1232        }
1233
1234        if {[info exists options(v)]} {
1235            ui_notice "ln: $linktarget -> $file"
1236        }
1237        if {[info exists options(s)]} {
1238            symlink $file $linktarget
1239        } else {
1240            file link -hard $linktarget $file
1241        }
1242    }
1243    return
1244}
1245
1246# makeuserproc
1247# This procedure re-writes the user-defined custom target to include
1248# all the globals in its scope.  This is undeniably ugly, but I haven't
1249# thought of any other way to do this.
1250proc makeuserproc {name body} {
1251    regsub -- "^\{(.*?)" $body "\{ \n foreach g \[info globals\] \{ \n global \$g \n \} \n \\1" body
1252    eval "proc $name {} $body"
1253}
1254
1255# backup
1256# Operates on universal_filelist, creates universal_archlist
1257# Save single-architecture files, a temporary location, preserving the original
1258# directory structure.
1259
1260proc backup {arch} {
1261    global universal_archlist universal_filelist workpath
1262    lappend universal_archlist ${arch}
1263    foreach file ${universal_filelist} {
1264        set filedir [file dirname $file]
1265        xinstall -d ${workpath}/${arch}/${filedir}
1266        xinstall ${file} ${workpath}/${arch}/${filedir}
1267    }
1268}
1269
1270# lipo
1271# Operates on universal_filelist, universal_archlist.
1272# Run lipo(1) on a list of single-arch files.
1273
1274proc lipo {} {
1275    global universal_archlist universal_filelist workpath
1276    foreach file ${universal_filelist} {
1277        xinstall -d [file dirname $file]
1278        file delete ${file}
1279        set lipoSources ""
1280        foreach arch $universal_archlist {
1281            append lipoSources "-arch ${arch} ${workpath}/${arch}/${file} "
1282        }
1283        system "[findBinary lipo $portutil::autoconf::lipo_path] ${lipoSources}-create -output ${file}"
1284    }
1285}
1286
1287
1288# unobscure maintainer addresses as used in Portfiles
1289# We allow two obscured forms:
1290#   (1) User name only with no domain:
1291#           foo implies foo@macports.org
1292#   (2) Mangled name:
1293#           subdomain.tld:username implies username@subdomain.tld
1294#
1295proc unobscure_maintainers { list } {
1296    set result {}
1297    foreach m $list {
1298        if {[string first "@" $m] < 0} {
1299            if {[string first ":" $m] >= 0} {
1300                set m [regsub -- "(.*):(.*)" $m "\\2@\\1"]
1301            } else {
1302                set m "$m@macports.org"
1303            }
1304        }
1305        lappend result $m
1306    }
1307    return $result
1308}
1309
1310
1311
1312
1313########### Internal Dependency Manipulation Procedures ###########
1314global ports_dry_last_skipped
1315set ports_dry_last_skipped ""
1316
1317proc target_run {ditem} {
1318    global target_state_fd workpath portpath ports_trace PortInfo ports_dryrun \
1319           ports_dry_last_skipped worksrcpath prefix subport env portdbpath \
1320           macosx_version
1321    set portname $subport
1322    set result 0
1323    set skipped 0
1324    set procedure [ditem_key $ditem procedure]
1325    set savedhome [file join $portdbpath home]
1326    set env(HOME) "${workpath}/.home"
1327    set env(TMPDIR) "${workpath}/.tmp"
1328
1329    if {[ditem_key $ditem state] != "no"} {
1330        set target_state_fd [open_statefile]
1331    }
1332
1333    if {$procedure != ""} {
1334        set targetname [ditem_key $ditem name]
1335        set target [ditem_key $ditem provides]
1336        portsandbox::set_profile $target
1337        global ${target}.asroot
1338        if { [tbool ${target}.asroot] } {
1339            elevateToRoot $targetname
1340        }
1341
1342        if {[ditem_contains $ditem init]} {
1343            set result [catch {[ditem_key $ditem init] $targetname} errstr]
1344            # Save variables in order to re-throw the same error code.
1345            set errcode $::errorCode
1346            set errinfo $::errorInfo
1347        }
1348
1349        if {$result == 0} {
1350            # Skip the step if required and explain why through ui_debug.
1351            # check if the step was already done (as mentioned in the state file)
1352            if {[ditem_key $ditem state] != "no"
1353                    && [check_statefile target $targetname $target_state_fd]} {
1354                ui_debug "Skipping completed $targetname ($portname)"
1355                set skipped 1
1356            }
1357
1358            # Of course, if this is a dry run, don't do the task:
1359            if {[info exists ports_dryrun] && $ports_dryrun == "yes"} {
1360                # only one message per portname
1361                if {$portname != $ports_dry_last_skipped} {
1362                    ui_notice "For $portname: skipping $targetname (dry run)"
1363                    set ports_dry_last_skipped $portname
1364                } else {
1365                    ui_info "    .. and skipping $targetname"
1366                }
1367                set skipped 1
1368            }
1369
1370            # otherwise execute the task.
1371            if {$skipped == 0} {
1372                # change current phase shown in log
1373                set_phase $target
1374
1375                # Execute pre-run procedure
1376                if {[ditem_contains $ditem prerun]} {
1377                    set result [catch {[ditem_key $ditem prerun] $targetname} errstr]
1378                    # Save variables in order to re-throw the same error code.
1379                    set errcode $::errorCode
1380                    set errinfo $::errorInfo
1381                }
1382
1383                #start tracelib
1384                if {($result ==0
1385                  && [info exists ports_trace]
1386                  && $ports_trace == "yes"
1387                  && $target != "clean")} {
1388                    porttrace::trace_start $workpath
1389
1390                    # Enable the fence to prevent any creation/modification
1391                    # outside the sandbox.
1392                    if {$target != "activate"
1393                      && $target != "archive"
1394                      && $target != "install"} {
1395                        porttrace::trace_enable_fence
1396                    }
1397
1398                    # collect deps
1399                    set depends {}
1400                    set deptypes {}
1401
1402                    # Determine deptypes to look for based on target
1403                    switch $target {
1404                        fetch       -
1405                        checksum    { set deptypes "depends_fetch" }
1406                        extract     -
1407                        patch       { set deptypes "depends_fetch depends_extract" }
1408                        configure   -
1409                        build       { set deptypes "depends_fetch depends_extract depends_lib depends_build" }
1410
1411                        test        -
1412                        destroot    -
1413                        install     -
1414                        dmg         -
1415                        pkg         -
1416                        portpkg     -
1417                        mpkg        -
1418                        rpm         -
1419                        srpm        -
1420                        dpkg        -
1421                        mdmg        -
1422                        activate    -
1423                        ""          { set deptypes "depends_fetch depends_extract depends_lib depends_build depends_run" }
1424                    }
1425
1426                    # Gather the dependencies for deptypes
1427                    foreach deptype $deptypes {
1428                        # Add to the list of dependencies if the option exists and isn't empty.
1429                        if {[info exists PortInfo($deptype)] && $PortInfo($deptype) != ""} {
1430                            set depends [concat $depends $PortInfo($deptype)]
1431                        }
1432                    }
1433
1434                    # Recursively collect all dependencies from registry for tracing
1435                    set deplist {}
1436                    foreach depspec $depends {
1437                        # Resolve dependencies to actual ports
1438                        set name [_get_dep_port $depspec]
1439
1440                        # If portname is empty, the dependency is already satisfied by other means,
1441                        # for example a bin: dependency on a file not installed by MacPorts
1442                        if {$name != ""} {
1443                            if {[lsearch -exact $deplist $name] == -1} {
1444                                lappend deplist $name
1445                                set deplist [recursive_collect_deps $name $deplist]
1446                            }
1447                        }
1448                    }
1449
1450                    # Add ccache port for access to ${prefix}/bin/ccache binary
1451                    if [option configure.ccache] {
1452                        lappend deplist ccache
1453                    }
1454
1455                    ui_debug "Tracemode will respect recursively collected port dependencies: [lsort $deplist]"
1456
1457                    if {[llength $deptypes] > 0} {tracelib setdeps $deplist}
1458                }
1459
1460                if {$result == 0} {
1461                    foreach pre [ditem_key $ditem pre] {
1462                        ui_debug "Executing $pre"
1463                        set result [catch {$pre $targetname} errstr]
1464                        # Save variables in order to re-throw the same error code.
1465                        set errcode $::errorCode
1466                        set errinfo $::errorInfo
1467                        if {$result != 0} { break }
1468                    }
1469                }
1470
1471                if {$result == 0} {
1472                    ui_debug "Executing $targetname ($portname)"
1473                    set result [catch {$procedure $targetname} errstr]
1474                    # Save variables in order to re-throw the same error code.
1475                    set errcode $::errorCode
1476                    set errinfo $::errorInfo
1477                }
1478
1479                if {$result == 0} {
1480                    foreach post [ditem_key $ditem post] {
1481                        ui_debug "Executing $post"
1482                        set result [catch {$post $targetname} errstr]
1483                        # Save variables in order to re-throw the same error code.
1484                        set errcode $::errorCode
1485                        set errinfo $::errorInfo
1486                        if {$result != 0} { break }
1487                    }
1488                }
1489                # Execute post-run procedure
1490                if {[ditem_contains $ditem postrun] && $result == 0} {
1491                    set postrun [ditem_key $ditem postrun]
1492                    ui_debug "Executing $postrun"
1493                    set result [catch {$postrun $targetname} errstr]
1494                    # Save variables in order to re-throw the same error code.
1495                    set errcode $::errorCode
1496                    set errinfo $::errorInfo
1497                }
1498
1499                # Check dependencies & file creations outside workpath.
1500                if {[info exists ports_trace]
1501                  && $ports_trace == "yes"
1502                  && $target!="clean"} {
1503
1504                    tracelib closesocket
1505
1506                    porttrace::trace_check_violations
1507
1508                    # End of trace.
1509                    porttrace::trace_stop
1510                }
1511            }
1512        }
1513        if {[exists copy_log_files]} {
1514            set log_files [option copy_log_files]
1515            set log_dir [getportlogpath $portpath $subport]
1516            file mkdir $log_dir
1517 
1518            foreach log_file $log_files {
1519                set from "$worksrcpath/$log_file"
1520                if {[file exists $from]} {
1521                    file copy -force $from $log_dir
1522                }
1523            }
1524        }
1525        if {$result == 0} {
1526            # Only write to state file if:
1527            # - we indeed performed this step.
1528            # - this step is not to always be performed
1529            # - this step must be written to file
1530            if {$skipped == 0
1531          && [ditem_key $ditem runtype] != "always"
1532          && [ditem_key $ditem state] != "no"} {
1533            write_statefile target $targetname $target_state_fd
1534            }
1535        } else {
1536            ui_error "$targetname for port $portname returned: $errstr"
1537            ui_debug "Error code: $errcode"
1538            ui_debug "Backtrace: $errinfo"
1539            set result 1
1540        }
1541
1542    } else {
1543        ui_info "Warning: $targetname does not have a registered procedure"
1544        set result 1
1545    }
1546
1547    if {[ditem_key $ditem state] != "no"} {
1548        close $target_state_fd
1549    }
1550
1551    set env(HOME) $savedhome
1552    if {[info exists env(TMPDIR)]} {
1553        unset env(TMPDIR)
1554        if {$macosx_version == "10.5"} {
1555            unsetenv TMPDIR
1556        }
1557    }
1558
1559    return $result
1560}
1561
1562# recursive dependency search for portname
1563proc recursive_collect_deps {portname {depsfound {}}} \
1564{
1565    # Get the active port from the registry
1566    # There can be only one port active at a time, so take the first result only
1567    set regentry [lindex [registry_active $portname] 0]
1568    # Get port dependencies from the registry
1569    set deplist [registry_list_depends [lindex $regentry 0] [lindex $regentry 1] [lindex $regentry 2] [lindex $regentry 3]]
1570
1571    foreach item $deplist {
1572        set name [lindex $item 0]
1573        if {[lsearch -exact $depsfound $name] == -1} {
1574            lappend depsfound $name
1575            set depsfound [recursive_collect_deps $name $depsfound]
1576        }
1577    }
1578
1579    return $depsfound
1580}
1581
1582
1583proc eval_targets {target} {
1584    global targets target_state_fd subport version revision portvariants epoch ports_dryrun user_options
1585    set dlist $targets
1586
1587    # the statefile will likely be autocleaned away after install,
1588    # so special-case already-completed install and activate
1589    if {[registry_exists $subport $version $revision $portvariants]} {
1590        if {$target == "install"} {
1591            ui_debug "Skipping $target ($subport) since this port is already installed"
1592            return 0
1593        } elseif {$target == "activate"} {
1594            set regref [registry_open $subport $version $revision $portvariants ""]
1595            if {[registry_prop_retr $regref active] != 0} {
1596                # Something to close the registry entry may be called here, if it existed.
1597                ui_debug "Skipping $target ($subport @${version}_${revision}${portvariants}) since this port is already active"
1598                return 0
1599            } else {
1600                # run the activate target but ignore its (completed) dependencies
1601                set result [target_run [lindex [dlist_search $dlist provides $target] 0]]
1602                if {[getuid] == 0 && [geteuid] != 0} {
1603                    seteuid 0; setegid 0
1604                }
1605                return $result
1606            }
1607        }
1608    }
1609
1610    # Select the subset of targets under $target
1611    if {$target != ""} {
1612        set matches [dlist_search $dlist provides $target]
1613
1614        if {[llength $matches] > 0} {
1615            set dlist [dlist_append_dependents $dlist [lindex $matches 0] [list]]
1616            # Special-case 'all'
1617        } elseif {$target != "all"} {
1618            ui_error "unknown target: $target"
1619            return 1
1620        }
1621    }
1622
1623    set dlist [dlist_eval $dlist "" target_run]
1624
1625    if {[getuid] == 0 && [geteuid] != 0} {
1626        seteuid 0; setegid 0
1627    }
1628
1629    if {[llength $dlist] > 0} {
1630        # somebody broke!
1631        set errstring "Warning: targets not executed for $subport:"
1632        foreach ditem $dlist {
1633            append errstring " [ditem_key $ditem name]"
1634        }
1635        ui_info $errstring
1636        set result 1
1637    } else {
1638        set result 0
1639    }
1640
1641    return $result
1642}
1643
1644# open_statefile
1645# open file to store name of completed targets
1646proc open_statefile {args} {
1647    global workpath worksymlink place_worksymlink subport portpath ports_ignore_different ports_dryrun \
1648           usealtworkpath altprefix env applications_dir subbuildpath
1649
1650    if {$usealtworkpath} {
1651         ui_warn_once "privileges" "MacPorts running without privileges.\
1652                You may be unable to complete certain actions (e.g. install)."
1653
1654        set newsourcepath "${altprefix}${portpath}"
1655   
1656        # copy Portfile (and patch files) if not there already
1657        # note to maintainers/devs: the original portfile in /opt/local is ALWAYS the one that will be
1658        #    read by macports. The copying of the portfile is done to preserve the symlink provided
1659        #    historically by macports from the portfile directory to the work directory.
1660        #    It is NOT read by MacPorts.
1661        if {![file exists ${newsourcepath}/Portfile] && ![tbool ports_dryrun]} {
1662            file mkdir $newsourcepath
1663            ui_debug "$newsourcepath created"
1664            ui_debug "Going to copy: ${portpath}/Portfile"
1665            file copy ${portpath}/Portfile $newsourcepath
1666            if {[file exists ${portpath}/files] } {
1667                ui_debug "Going to copy: ${portpath}/files"
1668                file copy ${portpath}/files $newsourcepath
1669            }
1670        }
1671    }
1672
1673    if {![tbool ports_dryrun]} {
1674        set need_chown 0
1675        if {![file isdirectory $workpath/.home]} {
1676            file mkdir $workpath/.home
1677            set need_chown 1
1678        }
1679        if {![file isdirectory $workpath/.tmp]} {
1680            file mkdir $workpath/.tmp
1681            set need_chown 1
1682        }
1683        if {$need_chown} {
1684            chownAsRoot $subbuildpath
1685        }
1686        # Create a symlink to the workpath for port authors
1687        if {[tbool place_worksymlink] && ![file isdirectory $worksymlink]} {
1688            ui_debug "Attempting ln -sf $workpath $worksymlink"
1689            ln -sf $workpath $worksymlink
1690        }
1691    }
1692
1693    # de-escalate privileges if MacPorts was started with sudo
1694    dropPrivileges
1695
1696    # flock Portfile
1697    set statefile [file join $workpath .macports.${subport}.state]
1698    set fresh_build yes
1699    set checksum_portfile [sha256 file ${portpath}/Portfile]
1700    if {[file exists $statefile]} {
1701        set fresh_build no
1702        if {![file writable $statefile] && ![tbool ports_dryrun]} {
1703            return -code error "$statefile is not writable - check permission on port directory"
1704        }
1705        if {[file mtime ${portpath}/Portfile] > [clock seconds]} {
1706            return -code error "Portfile is from the future - check date and time of your system"
1707        }
1708        if {![tbool ports_ignore_different]} {
1709            # start by assuming the statefile is current
1710            set portfile_changed no
1711
1712            # open the statefile, determine the statefile version
1713            set readfd [open $statefile r]
1714            set statefile_version 1
1715            if {[get_statefile_value "version" $readfd result] != 0} {
1716                set statefile_version $result
1717            }
1718
1719            # check for outdated statefiles depending on what version the
1720            # statefile is; we explicitly support older statefiles here, because
1721            # all previously built archives would be invalidated (e.g., when
1722            # using mpkg) if we didn't
1723            switch $statefile_version {
1724                1 {
1725                    # statefile version 1
1726                    # this statefile doesn't have a checksum, fall back to
1727                    # comparing the Portfile modification date with the
1728                    # statefile modification date
1729                    if {[file mtime $statefile] < [file mtime ${portpath}/Portfile]} {
1730                        ui_debug "Statefile has version 1 and is older than Portfile"
1731                        set portfile_changed yes
1732                    }
1733                }
1734                2 {
1735                    # statefile version 2
1736                    # this statefile has a sha256 checksum of the Portfile in
1737                    # the "checksum" key
1738                    set checksum_statefile ""
1739                    if {[get_statefile_value "checksum" $readfd checksum_statefile] == 0} {
1740                        ui_warn "Statefile has version 2 but didn't contain a checksum"
1741                        set portfile_changed yes
1742                    } else {
1743                        if {$checksum_portfile != $checksum_statefile} {
1744                            ui_debug "Checksum recorded in statefile '$checksum_statefile' differs from Portfile checksum '$checksum_portfile'"
1745                            set portfile_changed yes
1746                        }
1747                    }
1748                }
1749                default {
1750                    ui_warn "Unsupported statefile version '$statefile_version'"
1751                    ui_warn "Please run 'port selfupdate' to update to the latest version of MacPorts"
1752                }
1753            }
1754            if {[tbool portfile_changed]} {
1755                if {![tbool ports_dryrun]} {
1756                    ui_notice "Portfile changed since last build; discarding previous state."
1757                    chownAsRoot $subbuildpath
1758                    delete $workpath
1759                    file mkdir $workpath
1760                    set fresh_build yes
1761                } else {
1762                    ui_notice "Portfile changed since last build but not discarding previous state (dry run)"
1763                }
1764            }
1765            close $readfd
1766        }
1767    } elseif {[tbool ports_dryrun]} {
1768        set statefile /dev/null
1769    }
1770
1771    set fd [open $statefile a+]
1772    if {![tbool ports_dryrun]} {
1773        if {[catch {flock $fd -exclusive -noblock} result]} {
1774            if {"$result" == "EAGAIN"} {
1775                ui_notice "Waiting for lock on $statefile"
1776                flock $fd -exclusive
1777            } elseif {"$result" == "EOPNOTSUPP"} {
1778                # Locking not supported, just return
1779                return $fd
1780            } else {
1781                return -code error "$result obtaining lock on $statefile"
1782            }
1783        }
1784    }
1785    if {[tbool fresh_build]} {
1786        write_statefile "version" 2 $fd
1787        write_statefile "checksum" $checksum_portfile $fd
1788    }
1789    return $fd
1790}
1791
1792# get_statefile_value
1793# Check for a given $class in the statefile $fd and write the first match to
1794# $result, if any. Returns 1 if a line matched, 0 otherwise
1795proc get_statefile_value {class fd result} {
1796    upvar $result upresult
1797    seek $fd 0
1798    while {[gets $fd line] >= 0} {
1799        if {[regexp "$class: (.*)" $line match value]} {
1800            set upresult $value
1801            return 1
1802        }
1803    }
1804    return 0
1805}
1806
1807# check_statefile
1808# Check completed/selected state of target/variant $name
1809proc check_statefile {class name fd} {
1810    seek $fd 0
1811    while {[gets $fd line] >= 0} {
1812        if {$line == "$class: $name"} {
1813            return 1
1814        }
1815    }
1816    return 0
1817}
1818
1819# write_statefile
1820# Set target $name completed in the state file
1821proc write_statefile {class name fd} {
1822    if {[check_statefile $class $name $fd]} {
1823        return 0
1824    }
1825    seek $fd 0 end
1826    puts $fd "$class: $name"
1827    flush $fd
1828}
1829
1830##
1831# Check that recorded selection of variants match the current selection
1832#
1833# @param variations input array name of new variants
1834# @param oldvariations output array name of old variants
1835# @param fd file descriptor of the state file
1836# @return 0 if variants match, 1 otherwise
1837proc check_statefile_variants {variations oldvariations fd} {
1838    upvar $variations upvariations
1839    upvar $oldvariations upoldvariations
1840
1841    array set upoldvariations {}
1842
1843    set variants_found no
1844    set targets_found no
1845    seek $fd 0
1846    while {[gets $fd line] >= 0} {
1847        if {[regexp "variant: (.*)" $line match name]} {
1848            set upoldvariations([string range $name 1 end]) [string range $name 0 0]
1849            set variants_found yes
1850        }
1851        if {[regexp "target: .*" $line]} {
1852            set targets_found yes
1853        }
1854    }
1855
1856    if {![tbool variants_found] && ![tbool targets_found]} {
1857        # Statefile is "empty", skipping further tests
1858        return 0
1859    }
1860
1861    set mismatch 0
1862    if {[array size upoldvariations] != [array size upvariations]} {
1863        set mismatch 1
1864    } else {
1865        foreach key [array names upvariations *] {
1866            if {![info exists upoldvariations($key)] || $upvariations($key) != $upoldvariations($key)} {
1867                set mismatch 1
1868                break
1869            }
1870        }
1871    }
1872
1873    return $mismatch
1874}
1875
1876########### Port Variants ###########
1877
1878# Each variant which provides a subset of the requested variations
1879# will be chosen.  Returns a list of the selected variants.
1880proc choose_variants {dlist variations} {
1881    upvar $variations upvariations
1882
1883    set selected [list]
1884    set negated [list]
1885
1886    foreach ditem $dlist {
1887        # Enumerate through the provides, tallying the pros and cons.
1888        set pros 0
1889        set cons 0
1890        set ignored 0
1891        foreach flavor [ditem_key $ditem provides] {
1892            if {[info exists upvariations($flavor)]} {
1893                if {$upvariations($flavor) == "+"} {
1894                    incr pros
1895                } elseif {$upvariations($flavor) == "-"} {
1896                    incr cons
1897                }
1898            } else {
1899                incr ignored
1900            }
1901        }
1902
1903        if {$cons > 0} {
1904            lappend negated $ditem
1905        }
1906        if {$pros > 0 && $ignored == 0} {
1907            lappend selected $ditem
1908        }
1909    }
1910    return [list $selected $negated]
1911}
1912
1913proc variant_run {ditem} {
1914    set name [ditem_key $ditem name]
1915    ui_debug "Executing variant $name provides [ditem_key $ditem provides]"
1916
1917    # test for conflicting variants
1918    foreach v [ditem_key $ditem conflicts] {
1919        if {[variant_isset $v]} {
1920            ui_error "[option name]: Variant $name conflicts with $v"
1921            return 1
1922        }
1923    }
1924
1925    # execute proc with same name as variant.
1926    if {[catch "variant-${name}" result]} {
1927        global errorInfo
1928        ui_debug "$errorInfo"
1929        ui_error "[option name]: Error executing $name: $result"
1930        return 1
1931    }
1932    return 0
1933}
1934
1935# Given a list of variant specifications, return a canonical string form
1936# for the registry.
1937    # The strategy is as follows: regardless of how some collection of variants
1938    # was turned on or off, a particular instance of the port is uniquely
1939    # characterized by the set of variants that are *on*. Thus, record those
1940    # variants in a string in a standard order as +var1+var2 etc.
1941    # Can also do the same for -variants, for recording the negated list.
1942proc canonicalize_variants {variants {sign "+"}} {
1943    array set vara $variants
1944    set result ""
1945    set vlist [lsort -ascii [array names vara]]
1946    foreach v $vlist {
1947        if {$vara($v) == $sign} {
1948            append result "${sign}${v}"
1949        }
1950    }
1951    return $result
1952}
1953
1954proc eval_variants {variations} {
1955    global all_variants ports_force PortInfo requested_variations portvariants negated_variants
1956    set dlist $all_variants
1957    upvar $variations upvariations
1958    set chosen [choose_variants $dlist upvariations]
1959    set negated [lindex $chosen 1]
1960    set chosen [lindex $chosen 0]
1961    set portname [option subport]
1962
1963    # Check to make sure the requested variations are available with this
1964    # port, if one is not, warn the user and remove the variant from the
1965    # array.
1966    # Save the originally requested set in requested_variations.
1967    array set requested_variations [array get upvariations]
1968    foreach key [array names upvariations *] {
1969        if {![info exists PortInfo(variants)] ||
1970            [lsearch $PortInfo(variants) $key] == -1} {
1971            ui_debug "Requested variant $upvariations($key)$key is not provided by port $portname."
1972            array unset upvariations $key
1973        }
1974    }
1975
1976    # now that we've selected variants, change all provides [a b c] to [a-b-c]
1977    # this will eliminate ambiguity between item a, b, and a-b while fulfilling requirements.
1978    #foreach obj $dlist {
1979    #    $obj set provides [list [join [$obj get provides] -]]
1980    #}
1981
1982    set newlist [list]
1983    foreach variant $chosen {
1984        set newlist [dlist_append_dependents $dlist $variant $newlist]
1985    }
1986
1987    set dlist [dlist_eval $newlist "" variant_run]
1988    if {[llength $dlist] > 0} {
1989        return 1
1990    }
1991
1992    # Now compute the true active array of variants. Note we do not
1993    # change upvariations any further, since that represents the
1994    # requested list of variations; but the registry for consistency
1995    # must encode the actual list of variants evaluated, however that
1996    # came to pass (dependencies, defaults, etc.) While we're at it,
1997    # it's convenient to check for inconsistent requests for
1998    # variations, namely foo +requirer -required where the 'requirer'
1999    # variant requires the 'required' one.
2000    set activevariants [list]
2001    foreach dvar $newlist {
2002        set thevar [ditem_key $dvar provides]
2003        if {[info exists upvariations($thevar)] && $upvariations($thevar) eq "-"} {
2004            set chosenlist ""
2005            foreach choice $chosen {
2006                lappend chosenlist +[ditem_key $choice provides]
2007            }
2008            ui_error "Inconsistent variant specification: $portname variant +$thevar is required by at least one of $chosenlist, but specified -$thevar"
2009            return 1
2010        }
2011        lappend activevariants $thevar "+"
2012    }
2013
2014    # Record a canonical variant string, used e.g. in accessing the registry
2015    set portvariants [canonicalize_variants $activevariants]
2016
2017    # Make this important information visible in PortInfo
2018    set PortInfo(active_variants) $activevariants
2019    set PortInfo(canonical_active_variants) $portvariants
2020
2021    # now set the negated variants
2022    set negated_list [list]
2023    foreach dvar $negated {
2024        set thevar [ditem_key $dvar provides]
2025        lappend negated_list $thevar "-"
2026    }
2027    set negated_variants [canonicalize_variants $negated_list "-"]
2028
2029    return 0
2030}
2031
2032proc check_variants {target} {
2033    global targets ports_force ports_dryrun PortInfo
2034    set result 0
2035    array set variations $PortInfo(active_variants)
2036
2037    # Make sure the variations match those stored in the statefile.
2038    # If they don't match, print an error indicating a 'port clean'
2039    # should be performed.
2040    # - Skip this test if the target indicated target_state no
2041    # - Skip this test if the statefile is empty.
2042    # - Skip this test if ports_force was specified.
2043
2044    # Assume we do not need the statefile
2045    set statereq 0
2046    set ditems [dlist_search $targets provides $target]
2047    if {[llength $ditems] > 0} {
2048        set ditems [dlist_append_dependents $targets [lindex $ditems 0] [list]]
2049    }
2050    foreach d $ditems {
2051        if {[ditem_key $d state] != "no"} {
2052            # At least one matching target requires the state file
2053            set statereq 1
2054            break
2055        }
2056    }
2057    if { $statereq &&
2058        !([info exists ports_force] && $ports_force == "yes")} {
2059
2060        set state_fd [open_statefile]
2061
2062        array set oldvariations {}
2063        if {[check_statefile_variants variations oldvariations $state_fd]} {
2064            ui_error "Requested variants \"[canonicalize_variants [array get variations]]\" do not match original selection \"[canonicalize_variants [array get oldvariations]]\".\nPlease use the same variants again, perform 'port clean [option subport]' or specify the force option (-f)."
2065            set result 1
2066        } elseif {!([info exists ports_dryrun] && $ports_dryrun == "yes")} {
2067            # Write variations out to the statefile
2068            foreach key [array names variations *] {
2069                write_statefile variant $variations($key)$key $state_fd
2070            }
2071        }
2072
2073        close $state_fd
2074    }
2075
2076    return $result
2077}
2078
2079# add the default universal variant if appropriate
2080proc universal_setup {args} {
2081    if {[variant_exists universal]} {
2082        ui_debug "universal variant already exists, so not adding the default one"
2083    } elseif {[exists universal_variant] && ![option universal_variant]} {
2084        ui_debug "universal_variant is false, so not adding the default universal variant"
2085    } elseif {[exists use_xmkmf] && [option use_xmkmf]} {
2086        ui_debug "using xmkmf, so not adding the default universal variant"
2087    } elseif {![exists os.universal_supported] || ![option os.universal_supported]} {
2088        ui_debug "OS doesn't support universal builds, so not adding the default universal variant"
2089    } elseif {[llength [option supported_archs]] == 1} {
2090        ui_debug "only one arch supported, so not adding the default universal variant"
2091    } else {
2092        ui_debug "adding the default universal variant"
2093        variant universal {}
2094    }
2095}
2096
2097# Target class definition.
2098
2099# constructor for target object
2100proc target_new {name procedure} {
2101    global targets
2102    set ditem [ditem_create]
2103
2104    ditem_key $ditem name $name
2105    ditem_key $ditem procedure $procedure
2106
2107    lappend targets $ditem
2108
2109    return $ditem
2110}
2111
2112proc target_provides {ditem args} {
2113    global targets
2114    # Register the pre-/post- hooks for use in Portfile.
2115    # Portfile syntax: pre-fetch { puts "hello world" }
2116    # User-code exceptions are caught and returned as a result of the target.
2117    # Thus if the user code breaks, dependent targets will not execute.
2118    foreach target $args {
2119        set origproc [ditem_key $ditem procedure]
2120        set ident [ditem_key $ditem name]
2121        if {[info commands $target] == ""} {
2122            proc $target {args} "
2123                variable proc_index
2124                set proc_index \[llength \[ditem_key $ditem proc\]\]
2125                ditem_key $ditem procedure proc-${ident}-${target}-\${proc_index}
2126                proc proc-${ident}-${target}-\${proc_index} {name} \"
2127                    if {\\\[catch userproc-${ident}-${target}-\${proc_index} result\\\]} {
2128                        return -code error \\\$result
2129                    } else {
2130                        return 0
2131                    }
2132                \"
2133                proc do-$target {} { $origproc $target }
2134                makeuserproc userproc-${ident}-${target}-\${proc_index} \$args
2135            "
2136        }
2137        proc pre-$target {args} "
2138            variable proc_index
2139            set proc_index \[llength \[ditem_key $ditem pre\]\]
2140            ditem_append $ditem pre proc-pre-${ident}-${target}-\${proc_index}
2141            proc proc-pre-${ident}-${target}-\${proc_index} {name} \"
2142                if {\\\[catch userproc-pre-${ident}-${target}-\${proc_index} result\\\]} {
2143                    return -code error \\\$result
2144                } else {
2145                    return 0
2146                }
2147            \"
2148            makeuserproc userproc-pre-${ident}-${target}-\${proc_index} \$args
2149        "
2150        proc post-$target {args} "
2151            variable proc_index
2152            set proc_index \[llength \[ditem_key $ditem post\]\]
2153            ditem_append $ditem post proc-post-${ident}-${target}-\${proc_index}
2154            proc proc-post-${ident}-${target}-\${proc_index} {name} \"
2155                if {\\\[catch userproc-post-${ident}-${target}-\${proc_index} result\\\]} {
2156                    return -code error \\\$result
2157                } else {
2158                    return 0
2159                }
2160            \"
2161            makeuserproc userproc-post-${ident}-${target}-\${proc_index} \$args
2162        "
2163    }
2164    eval ditem_append $ditem provides $args
2165}
2166
2167proc target_requires {ditem args} {
2168    eval ditem_append $ditem requires $args
2169}
2170
2171proc target_uses {ditem args} {
2172    eval ditem_append $ditem uses $args
2173}
2174
2175proc target_deplist {ditem args} {
2176    eval ditem_append $ditem deplist $args
2177}
2178
2179proc target_prerun {ditem args} {
2180    eval ditem_append $ditem prerun $args
2181}
2182
2183proc target_postrun {ditem args} {
2184    eval ditem_append $ditem postrun $args
2185}
2186
2187proc target_runtype {ditem args} {
2188    eval ditem_append $ditem runtype $args
2189}
2190
2191proc target_state {ditem args} {
2192    eval ditem_append $ditem state $args
2193}
2194
2195proc target_init {ditem args} {
2196    eval ditem_append $ditem init $args
2197}
2198
2199##### variant class #####
2200
2201# constructor for variant objects
2202proc variant_new {name} {
2203    set ditem [ditem_create]
2204    ditem_key $ditem name $name
2205    return $ditem
2206}
2207
2208proc handle_default_variants {option action {value ""}} {
2209    global PortInfo variations
2210    switch -regex $action {
2211        set|append {
2212            # Retrieve the information associated with each variant.
2213            if {![info exists PortInfo(vinfo)]} {
2214                set PortInfo(vinfo) {}
2215            }
2216            array set vinfo $PortInfo(vinfo)
2217
2218            foreach v $value {
2219                if {[regexp {([-+])([-A-Za-z0-9_]+)} $v whole val variant] && ![info exists variations($variant)]} {
2220                    # Retrieve the information associated with this variant.
2221                    if {![info exists vinfo($variant)]} {
2222                        set vinfo($variant) {}
2223                    }
2224                    array unset info
2225                    array set info $vinfo($variant)
2226                    # Set is_default and update vinfo.
2227                    set info(is_default) $val
2228                    array set vinfo [list $variant [array get info]]
2229
2230                    set variations($variant) $val
2231                }
2232            }
2233            # Update PortInfo(vinfo).
2234            set PortInfo(vinfo) [array get vinfo]
2235        }
2236        delete {
2237            # xxx
2238        }
2239    }
2240}
2241
2242# create all users/groups listed in the add_users option
2243# format: [username [option=value ...] ...]
2244proc handle_add_users {} {
2245    set cur ""
2246    foreach val [option add_users] {
2247        if {[string match *=* $val] && $cur != ""} {
2248            set split_arg [split $val =]
2249            if {[lindex $split_arg 0] == "group"} {
2250                set groupname [lindex $split_arg 1]
2251                addgroup $groupname
2252                lappend args($cur) gid=[existsgroup $groupname]
2253            } else {
2254                lappend args($cur) $val
2255            }
2256        } else {
2257            set cur $val
2258        }
2259    }
2260    foreach username [array names args] {
2261        eval adduser $username $args($username)
2262    }
2263}
2264
2265proc adduser {name args} {
2266    global os.platform
2267
2268    if {[getuid] != 0} {
2269        ui_warn "adduser only works when running as root."
2270        ui_warn "The requested user '$name' was not created."
2271        return
2272    } elseif {[geteuid] != 0} {
2273        seteuid 0; setegid 0
2274        set escalated 1
2275    }
2276
2277    set passwd {*}
2278    set uid [nextuid]
2279    set gid [existsgroup nogroup]
2280    set realname ${name}
2281    set home /var/empty
2282    set shell /usr/bin/false
2283
2284    foreach arg $args {
2285        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
2286            set $key $val
2287        }
2288    }
2289
2290    if {[existsuser ${name}] != 0 || [existsuser ${uid}] != 0} {
2291        return
2292    }
2293
2294    if {${os.platform} eq "darwin"} {
2295        set dscl [findBinary dscl $portutil::autoconf::dscl_path]
2296        exec $dscl . -create /Users/${name} UniqueID ${uid}
2297
2298        # These are implicitly added on Mac OSX Lion.  AuthenticationAuthority
2299        # causes the user to be visible in the Users & Groups Preference Pane,
2300        # and the others are just noise, so delete them.
2301        # https://trac.macports.org/ticket/30168
2302        exec $dscl . -delete /Users/${name} AuthenticationAuthority
2303        exec $dscl . -delete /Users/${name} PasswordPolicyOptions
2304        exec $dscl . -delete /Users/${name} dsAttrTypeNative:KerberosKeys
2305        exec $dscl . -delete /Users/${name} dsAttrTypeNative:ShadowHashData
2306
2307        exec $dscl . -create /Users/${name} RealName ${realname}
2308        exec $dscl . -create /Users/${name} Password ${passwd}
2309        exec $dscl . -create /Users/${name} PrimaryGroupID ${gid}
2310        exec $dscl . -create /Users/${name} NFSHomeDirectory ${home}
2311        exec $dscl . -create /Users/${name} UserShell ${shell}
2312    } else {
2313        # XXX adduser is only available for darwin, add more support here
2314        ui_warn "adduser is not implemented on ${os.platform}."
2315        ui_warn "The requested user '$name' was not created."
2316    }
2317
2318    if {[info exists escalated]} {
2319        dropPrivileges
2320    }
2321}
2322
2323proc addgroup {name args} {
2324    global os.platform
2325
2326    if {[getuid] != 0} {
2327        ui_warn "addgroup only works when running as root."
2328        ui_warn "The requested group '$name' was not created."
2329        return
2330    } elseif {[geteuid] != 0} {
2331        seteuid 0; setegid 0
2332        set escalated 1
2333    }
2334
2335    set gid [nextgid]
2336    set realname ${name}
2337    set passwd {*}
2338    set users ""
2339
2340    foreach arg $args {
2341        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
2342            set $key $val
2343        }
2344    }
2345
2346    if {[existsgroup ${name}] != 0 || [existsgroup ${gid}] != 0} {
2347        return
2348    }
2349
2350    if {${os.platform} eq "darwin"} {
2351        set dscl [findBinary dscl $portutil::autoconf::dscl_path]
2352        exec $dscl . -create /Groups/${name} Password ${passwd}
2353        exec $dscl . -create /Groups/${name} RealName ${realname}
2354        exec $dscl . -create /Groups/${name} PrimaryGroupID ${gid}
2355        if {${users} ne ""} {
2356            exec $dscl . -create /Groups/${name} GroupMembership ${users}
2357        }
2358    } else {
2359        # XXX addgroup is only available for darwin, add more support here
2360        ui_warn "addgroup is not implemented on ${os.platform}."
2361        ui_warn "The requested group was not created."
2362    }
2363
2364    if {[info exists escalated]} {
2365        dropPrivileges
2366    }
2367}
2368
2369# proc to calculate size of a directory
2370# moved here from portpkg.tcl
2371proc dirSize {dir} {
2372    set size    0;
2373    foreach file [readdir $dir] {
2374        if {[file type [file join $dir $file]] == "link" } {
2375            continue
2376        }
2377        if {[file isdirectory [file join $dir $file]]} {
2378            incr size [dirSize [file join $dir $file]]
2379        } else {
2380            incr size [file size [file join $dir $file]];
2381        }
2382    }
2383    return $size;
2384}
2385
2386# Set the UI prefix to something standard (so it can be grepped for in output)
2387proc set_ui_prefix {} {
2388    global UI_PREFIX env
2389    if {[info exists env(UI_PREFIX)]} {
2390        set UI_PREFIX $env(UI_PREFIX)
2391    } else {
2392        set UI_PREFIX "---> "
2393    }
2394}
2395
2396# Use a specified group/version.
2397proc PortGroup {group version} {
2398    global porturl
2399
2400    set groupFile [getportresourcepath $porturl "port1.0/group/${group}-${version}.tcl"]
2401
2402    if {[file exists $groupFile]} {
2403        uplevel "source $groupFile"
2404    } else {
2405        ui_warn "PortGroup ${group} ${version} could not be located. ${group}-${version}.tcl does not exist."
2406    }
2407}
2408
2409# return filename of the archive for this port
2410proc get_portimage_name {} {
2411    global portdbpath subport version revision portvariants os.platform os.major portarchivetype
2412    set ret "${subport}-${version}_${revision}${portvariants}.${os.platform}_${os.major}.[join [get_canonical_archs] -].${portarchivetype}"
2413    # should really look up NAME_MAX here, but it's 255 for all OS X so far
2414    # (leave 10 chars for an extension like .rmd160 on the sig file)
2415    if {[string length $ret] > 245 && ${portvariants} != ""} {
2416        # try hashing the variants
2417        set ret "${subport}-${version}_${revision}+[rmd160 string ${portvariants}].${os.platform}_${os.major}.[join [get_canonical_archs] -].${portarchivetype}"
2418    }
2419    if {[string length $ret] > 245} {
2420        error "filename too long: $ret"
2421    }
2422    return $ret
2423}
2424
2425# return path where a newly created image/archive for this port will be stored
2426proc get_portimage_path {} {
2427    global portdbpath subport
2428    return [file join ${portdbpath} software ${subport} [get_portimage_name]]
2429}
2430
2431# return list of archive types that we can extract
2432proc supportedArchiveTypes {} {
2433    global supported_archive_types
2434    if {![info exists supported_archive_types]} {
2435        set supported_archive_types {}
2436        foreach type {tbz2 tbz tgz tar txz tlz xar zip cpgz cpio} {
2437            if {[catch {archiveTypeIsSupported $type}] == 0} {
2438                lappend supported_archive_types $type
2439            }
2440        }
2441    }
2442    return $supported_archive_types
2443}
2444
2445# return path to a downloaded or installed archive for this port
2446proc find_portarchive_path {} {
2447    global portdbpath subport version revision portvariants
2448    set installed 0
2449    if {[registry_exists $subport $version $revision $portvariants]} {
2450        set installed 1
2451    }
2452    set archiverootname [file rootname [get_portimage_name]]
2453    foreach unarchive.type [supportedArchiveTypes] {
2454        set fullarchivename "${archiverootname}.${unarchive.type}"
2455        if {$installed} {
2456            set fullarchivepath [file join $portdbpath software $subport $fullarchivename]
2457        } else {
2458            set fullarchivepath [file join $portdbpath incoming/verified $fullarchivename]
2459        }
2460        if {[file isfile $fullarchivepath]} {
2461            return $fullarchivepath
2462        }
2463    }
2464    return ""
2465}
2466
2467# check if archive type is supported by current system
2468# returns an error code if it is not
2469proc archiveTypeIsSupported {type} {
2470    global os.platform os.version
2471    set errmsg ""
2472    switch -regex $type {
2473        cp(io|gz) {
2474            set pax "pax"
2475            if {[catch {set pax [findBinary $pax ${portutil::autoconf::pax_path}]} errmsg] == 0} {
2476                if {[regexp {z$} $type]} {
2477                    set gzip "gzip"
2478                    if {[catch {set gzip [findBinary $gzip ${portutil::autoconf::gzip_path}]} errmsg] == 0} {
2479                        return 0
2480                    }
2481                } else {
2482                    return 0
2483                }
2484            }
2485        }
2486        t(ar|bz|lz|xz|gz) {
2487            set tar "tar"
2488            if {[catch {set tar [findBinary $tar ${portutil::autoconf::tar_path}]} errmsg] == 0} {
2489                if {[regexp {z2?$} $type]} {
2490                    if {[regexp {bz2?$} $type]} {
2491                        set gzip "bzip2"
2492                    } elseif {[regexp {lz$} $type]} {
2493                        set gzip "lzma"
2494                    } elseif {[regexp {xz$} $type]} {
2495                        set gzip "xz"
2496                    } else {
2497                        set gzip "gzip"
2498                    }
2499                    if {[info exists portutil::autoconf::${gzip}_path]} {
2500                        set hint [set portutil::autoconf::${gzip}_path]
2501                    } else {
2502                        set hint ""
2503                    }
2504                    if {[catch {set gzip [findBinary $gzip $hint]} errmsg] == 0} {
2505                        return 0
2506                    }
2507                } else {
2508                    return 0
2509                }
2510            }
2511        }
2512        xar {
2513            set xar "xar"
2514            if {[catch {set xar [findBinary $xar ${portutil::autoconf::xar_path}]} errmsg] == 0} {
2515                return 0
2516            }
2517        }
2518        zip {
2519            set zip "zip"
2520            if {[catch {set zip [findBinary $zip ${portutil::autoconf::zip_path}]} errmsg] == 0} {
2521                set unzip "unzip"
2522                if {[catch {set unzip [findBinary $unzip ${portutil::autoconf::unzip_path}]} errmsg] == 0} {
2523                    return 0
2524                }
2525            }
2526        }
2527        default {
2528            return -code error [format [msgcat::mc "Invalid port archive type '%s' specified!"] $type]
2529        }
2530    }
2531    return -code error [format [msgcat::mc "Unsupported port archive type '%s': %s"] $type $errmsg]
2532}
2533
2534#
2535# merge function for universal builds
2536#
2537
2538# private function
2539# merge_lipo base-path target-path relative-path architectures
2540# e.g. 'merge_lipo ${workpath}/pre-dest ${destroot} ${prefix}/bin/pstree i386 ppc
2541# will merge binary files with lipo which have to be in the same (relative) path
2542proc merge_lipo {base target file archs} {
2543    set exec-lipo [list [findBinary lipo $portutil::autoconf::lipo_path]]
2544    foreach arch ${archs} {
2545        lappend exec-lipo -arch ${arch} ${base}/${arch}${file}
2546    }
2547    eval exec ${exec-lipo} [list -create -output ${target}${file}]
2548}
2549
2550# private function
2551# merge C/C++/.. files
2552# either just copy (if equivalent) or add CPP directive for differences
2553# should work for C++, C, Obj-C, Obj-C++ files and headers
2554proc merge_cpp {base target file archs} {
2555    merge_file $base $target $file $archs
2556    # TODO -- instead of just calling merge_file:
2557    # check if different
2558    #   no: copy
2559    #   yes: merge with #elif defined(__i386__) (__x86_64__, __ppc__, __ppc64__)
2560}
2561
2562# private function
2563# merge_file base-path target-path relative-path architectures
2564# e.g. 'merge_file ${workpath}/pre-dest ${destroot} ${prefix}/share/man/man1/port.1 i386 ppc
2565# will test equivalence of files and copy them if they are the same (for the different architectures)
2566proc merge_file {base target file archs} {
2567    set basearch [lindex ${archs} 0]
2568    ui_debug "ba: '${basearch}' ('${archs}')"
2569    foreach arch [lrange ${archs} 1 end] {
2570        # checking for differences; TODO: error more gracefully on non-equal files
2571        exec [findBinary diff $portutil::autoconf::diff_path] "-q" "${base}/${basearch}${file}" "${base}/${arch}${file}"
2572    }
2573    ui_debug "ba: '${basearch}'"
2574    file copy "${base}/${basearch}${file}" "${target}${file}"
2575}
2576
2577# merges multiple "single-arch" destroots into the final destroot
2578# 'base' is the path where the different directories (one for each arch) are
2579# e.g. call 'merge ${workpath}/pre-dest' with having a destroot in ${workpath}/pre-dest/i386 and ${workpath}/pre-dest/ppc64 -- single arch -- each
2580proc merge {base} {
2581    global destroot configure.universal_archs
2582
2583    # test which architectures are available, set one as base-architecture
2584    set archs ""
2585    set base_arch ""
2586    foreach arch ${configure.universal_archs} {
2587        if [file exists "${base}/${arch}"] {
2588            set archs [concat ${archs} ${arch}]
2589            set base_arch ${arch}
2590        }
2591    }
2592    if {"" == ${base_arch}} {
2593        return -code error [format [msgcat::mc "Cannot merge because directory '%s' contains no architecture directories."] ${base}]
2594    }
2595    ui_debug "merging architectures ${archs}, base_arch is ${base_arch}"
2596
2597    # traverse the base-architecture directory
2598    set basepath "${base}/${base_arch}"
2599    fs-traverse file "${basepath}" {
2600        set fpath [string range "${file}" [string length "${basepath}"] [string length "${file}"]]
2601        if {${fpath} != ""} {
2602            # determine the type (dir/file/link)
2603            switch [file type ${basepath}${fpath}] {
2604                directory {
2605                    # just create directories
2606                    ui_debug "mrg: directory ${fpath}"
2607                    file mkdir "${destroot}${fpath}"
2608                }
2609                link {
2610                    # copy symlinks, TODO: check if targets match!
2611                    ui_debug "mrg: symlink ${fpath}"
2612                    file copy "${basepath}${fpath}" "${destroot}${fpath}"
2613                }
2614                default {
2615                    set filetype [exec [findBinary file $portutil::autoconf::file_path] "-b" "${basepath}${fpath}"]
2616                    switch -regexp ${filetype} {
2617                        Mach-O.* {
2618                            merge_lipo "${base}" "${destroot}" "${fpath}" "${archs}"
2619                        }
2620                        current\ ar\ archive {
2621                            merge_lipo "${base}" "${destroot}" "${fpath}" "${archs}"
2622                        }
2623                        ASCII\ C\ program\ text {
2624                            merge_cpp "${base}" "${destroot}" "${fpath}" "${archs}"
2625                        }
2626                        default {
2627                            ui_debug "unknown file type: ${filetype}"
2628                            merge_file "${base}" "${destroot}" "${fpath}" "${archs}"
2629                        }
2630                    }
2631                }
2632            }
2633        }
2634    }
2635}
2636
2637##
2638# Escape a string for safe use in regular expressions
2639#
2640# @param str the string to be quoted
2641# @return the escaped string
2642proc quotemeta {str} {
2643    regsub -all {(\W)} $str {\\\1} str
2644    return $str
2645}
2646
2647##
2648# Recusively chown the given file or directory to the specified user.
2649#
2650# @param path the file/directory to be chowned
2651# @param user the user to chown file to
2652proc chown {path user} {
2653    lchown $path $user
2654
2655    if {[file isdirectory $path]} {
2656        fs-traverse myfile ${path} {
2657            lchown $myfile $user
2658        }
2659    }
2660
2661}
2662
2663##
2664# Recusively chown the given file or directory to $macportsuser, using root privileges.
2665#
2666# @param path the file/directory to be chowned
2667proc chownAsRoot {path} {
2668    global euid egid macportsuser
2669
2670    if { [getuid] == 0 } {
2671        if {[geteuid] != 0} {
2672            # if started with sudo but have dropped the privileges
2673            seteuid $euid
2674            setegid $egid
2675            ui_debug "euid/egid changed to: [geteuid]/[getegid]"
2676            chown  ${path} ${macportsuser}
2677            ui_debug "chowned $path to $macportsuser"
2678            setegid [uname_to_gid "$macportsuser"]
2679            seteuid [name_to_uid "$macportsuser"]
2680            ui_debug "euid/egid changed to: [geteuid]/[getegid]"
2681        } else {
2682            # if started with sudo but have elevated back to root already
2683            chown  ${path} ${macportsuser}
2684        }
2685    }
2686}
2687
2688##
2689# Change attributes of file while running as root
2690#
2691# @param file the file in question
2692# @param attributes the attributes for the file
2693proc fileAttrsAsRoot {file attributes} {
2694    global euid egid macportsuser
2695    if {[getuid] == 0} {
2696        if {[geteuid] != 0} {
2697            # Started as root, but not root now
2698            seteuid $euid
2699            setegid $egid
2700            ui_debug "euid/egid changed to: [geteuid]/[getegid]"
2701            ui_debug "setting attributes on $file"
2702            eval file attributes {$file} $attributes
2703            setegid [uname_to_gid "$macportsuser"]
2704            seteuid [name_to_uid "$macportsuser"]
2705            ui_debug "euid/egid changed to: [geteuid]/[getegid]"
2706        } else {
2707            eval file attributes {$file} $attributes
2708        }
2709    } else {
2710        # not root, so can't set owner/group
2711        set permissions [lindex $attributes [expr [lsearch $attributes "-permissions"] + 1]]
2712        file attributes $file -permissions $permissions
2713    }
2714}
2715
2716##
2717# Elevate privileges back to root.
2718#
2719# @param action the action for which privileges are being elevated
2720proc elevateToRoot {action} {
2721    global euid egid macportsuser
2722
2723    if { [getuid] == 0 && [geteuid] != 0 } {
2724    # if started with sudo but have dropped the privileges
2725        ui_debug "Can't run $action on this port without elevated privileges. Escalating privileges back to root."
2726        seteuid $euid
2727        setegid $egid
2728        ui_debug "euid changed to: [geteuid]. egid changed to: [getegid]."
2729    } elseif { [getuid] != 0 } {
2730        return -code error "MacPorts requires root privileges for this action"
2731    }
2732}
2733
2734##
2735# de-escalate privileges from root to those of $macportsuser.
2736#
2737proc dropPrivileges {} {
2738    global euid egid macportsuser workpath
2739    if { [geteuid] == 0 } {
2740        if { [catch {
2741                if {[name_to_uid "$macportsuser"] != 0} {
2742                    ui_debug "changing euid/egid - current euid: $euid - current egid: $egid"
2743
2744                    #seteuid [name_to_uid [file attributes $workpath -owner]]
2745                    #setegid [name_to_gid [file attributes $workpath -group]]
2746
2747                    setegid [uname_to_gid "$macportsuser"]
2748                    seteuid [name_to_uid "$macportsuser"]
2749                    ui_debug "egid changed to: [getegid]"
2750                    ui_debug "euid changed to: [geteuid]"
2751                }
2752            }]
2753        } {
2754            ui_debug "$::errorInfo"
2755            ui_error "Failed to de-escalate privileges."
2756        }
2757    } else {
2758        ui_debug "Privilege de-escalation not attempted as not running as root."
2759    }
2760}
2761
2762proc validate_macportsuser {} {
2763    global macportsuser
2764    if {[getuid] == 0 && $macportsuser != "root" && 
2765        ([existsuser $macportsuser] == 0 || [existsgroup $macportsuser] == 0 )} {
2766        ui_warn "configured user/group $macportsuser does not exist, will build as root"
2767        set macportsuser "root"
2768    }
2769}
2770
2771# dependency analysis helpers
2772
2773### _libtest is private; subject to change without notice
2774# XXX - Architecture specific
2775# XXX - Rely on information from internal defines in cctools/dyld:
2776# define DEFAULT_FALLBACK_FRAMEWORK_PATH
2777# /Library/Frameworks:/Library/Frameworks:/Network/Library/Frameworks:/System/Library/Frameworks
2778# define DEFAULT_FALLBACK_LIBRARY_PATH /lib:/usr/local/lib:/lib:/usr/lib
2779#   -- Since /usr/local is bad, using /lib:/usr/lib only.
2780# Environment variables DYLD_FRAMEWORK_PATH, DYLD_LIBRARY_PATH,
2781# DYLD_FALLBACK_FRAMEWORK_PATH, and DYLD_FALLBACK_LIBRARY_PATH take precedence
2782
2783proc _libtest {depspec {return_match 0}} {
2784    global env prefix frameworks_dir os.platform
2785    set depline [lindex [split $depspec :] 1]
2786
2787    if {[info exists env(DYLD_FRAMEWORK_PATH)]} {
2788        lappend search_path $env(DYLD_FRAMEWORK_PATH)
2789    } else {
2790        lappend search_path ${frameworks_dir} /Library/Frameworks /Network/Library/Frameworks /System/Library/Frameworks
2791    }
2792    if {[info exists env(DYLD_FALLBACK_FRAMEWORK_PATH)]} {
2793        lappend search_path $env(DYLD_FALLBACK_FRAMEWORK_PATH)
2794    }
2795    if {[info exists env(DYLD_LIBRARY_PATH)]} {
2796        lappend search_path $env(DYLD_LIBRARY_PATH)
2797    }
2798    lappend search_path /lib /usr/lib ${prefix}/lib
2799    if {[info exists env(DYLD_FALLBACK_LIBRARY_PATH)]} {
2800        lappend search_path $env(DYLD_FALLBACK_LIBRARY_PATH)
2801    }
2802
2803    set i [string first . $depline]
2804    if {$i < 0} {set i [string length $depline]}
2805    set depname [string range $depline 0 [expr $i - 1]]
2806    set depversion [string range $depline $i end]
2807    regsub {\.} $depversion {\.} depversion
2808    if {${os.platform} == "darwin"} {
2809        set depregex \^${depname}${depversion}\\.dylib\$
2810    } else {
2811        set depregex \^${depname}\\.so${depversion}\$
2812    }
2813
2814    return [_mportsearchpath $depregex $search_path 0 $return_match]
2815}
2816
2817### _bintest is private; subject to change without notice
2818
2819proc _bintest {depspec {return_match 0}} {
2820    global env prefix
2821    set depregex [lindex [split $depspec :] 1]
2822
2823    set search_path [split $env(PATH) :]
2824
2825    set depregex \^$depregex\$
2826
2827    return [_mportsearchpath $depregex $search_path 1 $return_match]
2828}
2829
2830### _pathtest is private; subject to change without notice
2831
2832proc _pathtest {depspec {return_match 0}} {
2833    global env prefix
2834    set depregex [lindex [split $depspec :] 1]
2835
2836    # separate directory from regex
2837    set fullname $depregex
2838
2839    regexp {^(.*)/(.*?)$} "$fullname" match search_path depregex
2840
2841    if {[string index $search_path 0] != "/"} {
2842        # Prepend prefix if not an absolute path
2843        set search_path "${prefix}/${search_path}"
2844    }
2845
2846    set depregex \^$depregex\$
2847
2848    return [_mportsearchpath $depregex $search_path 0 $return_match]
2849}
2850
2851# returns the name of the port that will actually be satisfying $depspec
2852proc _get_dep_port {depspec} {
2853    set speclist [split $depspec :]
2854    set portname [lindex $speclist end]
2855    set res [_portnameactive $portname]
2856    if {$res != 0} {
2857        return $portname
2858    }
2859   
2860    set depfile ""
2861    switch [lindex $speclist 0] {
2862        bin {
2863            set depfile [_bintest $depspec 1]
2864        }
2865        lib {
2866            set depfile [_libtest $depspec 1]
2867        }
2868        path {
2869            set depfile [_pathtest $depspec 1]
2870        }
2871    }
2872    if {$depfile == ""} {
2873        return $portname
2874    } else {
2875        set theport [registry_file_registered $depfile]
2876        if {$theport != 0} {
2877            return $theport
2878        } else {
2879            return ""
2880        }
2881    }
2882}
2883
2884# returns the list of archs that the port is targeting
2885proc get_canonical_archs {} {
2886    global supported_archs os.arch configure.build_arch configure.universal_archs
2887    if {$supported_archs == "noarch"} {
2888        return "noarch"
2889    } elseif {[variant_exists universal] && [variant_isset universal]} {
2890        return [lsort -ascii ${configure.universal_archs}]
2891    } elseif {${configure.build_arch} != ""} {
2892        return ${configure.build_arch}
2893    } else {
2894        return ${os.arch}
2895    }
2896}
2897
2898# returns the flags that should be passed to the compiler to choose arch(s)
2899proc get_canonical_archflags {{tool cc}} {
2900    if {![variant_exists universal] || ![variant_isset universal]} {
2901        return [option configure.${tool}_archflags]
2902    } else {
2903        if {$tool == "cc" || $tool == "objc"} {
2904            set tool c
2905        }
2906        return [option configure.universal_${tool}flags]
2907    }
2908}
2909
2910# check that the selected archs are supported
2911proc check_supported_archs {} {
2912    global supported_archs build_arch universal_archs configure.build_arch configure.universal_archs subport
2913    if {$supported_archs == "noarch"} {
2914        return 0
2915    } elseif {[variant_exists universal] && [variant_isset universal]} {
2916        if {[llength ${configure.universal_archs}] > 1 || $universal_archs == ${configure.universal_archs}} {
2917            return 0
2918        } else {
2919            ui_error "$subport cannot be installed for the configured universal_archs '$universal_archs' because it only supports the arch(s) '$supported_archs'."
2920            return 1
2921        }
2922    } elseif {$build_arch == "" || ${configure.build_arch} != ""} {
2923        return 0
2924    }
2925    ui_error "$subport cannot be installed for the configured build_arch '$build_arch' because it only supports the arch(s) '$supported_archs'."
2926    return 1
2927}
2928
2929# check if the installed xcode version is new enough
2930proc _check_xcode_version {} {
2931    global os.subplatform macosx_version xcodeversion
2932
2933    if {${os.subplatform} == "macosx"} {
2934        switch $macosx_version {
2935            10.4 {
2936                set min 2.0
2937                set ok 2.4.1
2938                set rec 2.5
2939            }
2940            10.5 {
2941                set min 3.0
2942                set ok 3.1
2943                set rec 3.1.4
2944            }
2945            10.6 {
2946                set min 3.2
2947                set ok 3.2
2948                set rec 3.2.6
2949            }
2950            10.7 {
2951                set min 4.1
2952                set ok 4.1
2953                set rec 4.5.2
2954            }
2955            default {
2956                set min 4.4
2957                set ok 4.4
2958                set rec 4.5.2
2959            }
2960        }
2961        if {$xcodeversion == "none"} {
2962            ui_warn "Xcode does not appear to be installed; most ports will likely fail to build."
2963            if {[file exists "/Applications/Install Xcode.app"]} {
2964                ui_warn "You downloaded Xcode from the Mac App Store but didn't install it. Run \"Install Xcode\" in the /Applications folder."
2965            }
2966        } elseif {[vercmp $xcodeversion $min] < 0} {
2967            ui_error "The installed version of Xcode (${xcodeversion}) is too old to use on the installed OS version. Version $rec or later is recommended on Mac OS X ${macosx_version}."
2968            return 1
2969        } elseif {[vercmp $xcodeversion $ok] < 0} {
2970            ui_warn "The installed version of Xcode (${xcodeversion}) is known to cause problems. Version $rec or later is recommended on Mac OS X ${macosx_version}."
2971        }
2972
2973        # Xcode 4.3 requires the command-line utilities package to be
2974        # installed.
2975        if {[vercmp $xcodeversion 4.3] >= 0 ||
2976            ($xcodeversion == "none" && [file exists "/Applications/Xcode.app"])} {
2977            if {![file exists "/usr/bin/make"]} {
2978                ui_warn "The Command Line Tools for Xcode don't appear to be installed; most ports will likely fail to build."
2979                ui_warn "See http://guide.macports.org/chunked/installing.xcode.html for more information."
2980            }
2981        }
2982       
2983    }
2984    return 0
2985}
2986
2987# check if we can unarchive this port
2988proc _archive_available {} {
2989    global ports_source_only porturl portutil::archive_available_result
2990
2991    if {[info exists archive_available_result]} {
2992        return $archive_available_result
2993    }
2994
2995    if {[tbool ports_source_only]} {
2996        set archive_available_result 0
2997        return 0
2998    }
2999
3000    if {[find_portarchive_path] != ""} {
3001        set archive_available_result 1
3002        return 1
3003    }
3004
3005    set archiverootname [file rootname [get_portimage_name]]
3006    if {[file rootname [file tail $porturl]] == $archiverootname && [file extension $porturl] != ""} {
3007        set archive_available_result 1
3008        return 1
3009    }
3010
3011    # check if there's an archive available on the server
3012    global archive_sites
3013    set mirrors macports_archives
3014    if {[lsearch $archive_sites macports_archives::*] == -1} {
3015        set mirrors [lindex [split [lindex $archive_sites 0] :] 0]
3016    }
3017    if {$mirrors == {}} {
3018        set archive_available_result 0
3019        return 0
3020    }
3021    set archivetype $portfetch::mirror_sites::archive_type($mirrors)
3022    set archivename "${archiverootname}.${archivetype}"
3023    # grab first site, should conventionally be the master mirror
3024    set sites_entry [lindex $portfetch::mirror_sites::sites($mirrors) 0]
3025    # look for and strip off any tag, which will start with the first colon after the
3026    # first slash after the ://
3027    set lastcolon [string last : $sites_entry]
3028    set aftersep [expr [string first : $sites_entry] + 3]
3029    set firstslash [string first / $sites_entry $aftersep]
3030    if {$firstslash != -1 && $firstslash < $lastcolon} {
3031        incr lastcolon -1
3032        set site [string range $sites_entry 0 $lastcolon]
3033    } else {
3034        set site $sites_entry
3035    }
3036    if {[string index $site end] != "/"} {
3037        append site "/[option archive.subdir]"
3038    } else {
3039        append site [option archive.subdir]
3040    }
3041    set url [portfetch::assemble_url $site $archivename]
3042    if {![catch {curl getsize $url} result]} {
3043        set archive_available_result 1
3044        return 1
3045    }
3046
3047    set archive_available_result 0
3048    return 0
3049}
Note: See TracBrowser for help on using the repository browser.