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

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

base: Avoid overlap between existsuser/existsgroup error code and root/wheel's UID/GID, closes #45737

Return -1 from existsuser and existsgroup when a user or group does not exist.
Because these commands return the UID or GID in case of success, they could not
be used to check for the existence of the root user or the wheel group (UID/GID
0).

Since existsuser and existsgroup are used in adduser and addgroup in
port1.0/portutil.tcl, putting add_user root into a Portfile would make MacPorts
trash the system's root user by replacing it with a new user with a non-zero
UID, effectively stripping the root user from its privileges.

This caused a problem in the dbus port when installed in a root MacPorts
installation with the +no_root variant, which is explained in #45737.

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