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

Last change on this file since 72230 was 72230, checked in by snc@…, 8 years ago

don't drop privs here: state file permissions error

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