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

Last change on this file was 152447, checked in by raimue@…, 2 years ago

portutil: update recommended Xcode versions

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