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

Last change on this file since 132312 was 132312, checked in by cal@…, 5 years ago

base: ignore stderr when extracting archive metadata, prevents breakage with gnutar, closes #42492

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