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

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

Rewrite logic for skipping install and activate targets when the port is
already installed or active. Fixes #16260. Also removes the need to use -f
when explicitly running a target prior to install for an installed port.

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