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

Last change on this file since 42662 was 42662, checked in by raimue@…, 9 years ago

Merged revisions 34469,34852,34854-34855,34900,36952-36956,37507-37508,37511-37512,41040,41042-41046,41138-41139,41142-41143,41145,41151,41403,41458,41462-41463,42575,42626,42640-42641,42659 via svnmerge from
https://svn.macosforge.org/repository/macports/branches/variant-descs-14482/base

........

r34469 | raimue@… | 2008-02-26 07:08:09 +0100 (Tue, 26 Feb 2008) | 3 lines


port/port.tcl:
Reading from .config/variant_descriptions actually works

........

r34852 | raimue@… | 2008-03-09 02:45:22 +0100 (Sun, 09 Mar 2008) | 4 lines


macports1.0/macports.tcl:
New API: macports::getsourceconfigdir
Returns the path to .config for a porturl.

........

r34854 | raimue@… | 2008-03-09 03:11:27 +0100 (Sun, 09 Mar 2008) | 3 lines


port/port.tcl:
Use new API macports::getsourceconfigdir

........

r34855 | raimue@… | 2008-03-09 03:12:54 +0100 (Sun, 09 Mar 2008) | 3 lines


port/port.tcl:
Treat variant descriptions as strings to avoid problems with braces

........

r34900 | raimue@… | 2008-03-10 16:54:25 +0100 (Mon, 10 Mar 2008) | 3 lines


port/port.tcl:
Rename variable

........

r36952 | raimue@… | 2008-05-21 04:20:27 +0200 (Wed, 21 May 2008) | 3 lines


port/port.tcl:
Remove get_variant_desc, this will now be done in port1.0/portutil.tcl instead

........

r36953 | raimue@… | 2008-05-21 04:22:04 +0200 (Wed, 21 May 2008) | 3 lines


macports1.0/macports.tcl:
Give the worker access to variable porturl and proc getsourceconfigdir

........

r36954 | raimue@… | 2008-05-21 04:23:37 +0200 (Wed, 21 May 2008) | 3 lines


port1.0/tests:
Fix the portutil test after r36953

........

r36955 | raimue@… | 2008-05-21 05:01:11 +0200 (Wed, 21 May 2008) | 3 lines


macports1.0/macports.tcl:
Give worker access to getprotocol and getportdir as they are needed for getsourceconfigdir

........

r36956 | raimue@… | 2008-05-21 05:02:23 +0200 (Wed, 21 May 2008) | 3 lines


port1.0/portutil.tcl:
New proc variant_desc, reads global variant description file

........

r37507 | raimue@… | 2008-06-10 16:04:54 +0200 (Tue, 10 Jun 2008) | 4 lines


port1.0/portutil.tcl:
Don't warn about a missing description if it is set global,
but warn if the variant overrides the global description

........

r37508 | raimue@… | 2008-06-10 16:14:03 +0200 (Tue, 10 Jun 2008) | 3 lines


macports1.0/macports.tcl:
Use .resources instead of .config as it is a bit clearer, see #14553

........

r37511 | raimue@… | 2008-06-10 17:22:12 +0200 (Tue, 10 Jun 2008) | 5 lines


port1.0/portutil.tcl:
Switch back to this format:
name {description}
So this could be easily extended if ever needed.

........

r37512 | raimue@… | 2008-06-10 17:27:48 +0200 (Tue, 10 Jun 2008) | 3 lines


port1.0/portutil.tcl:
Add a warning if global variant description file could not be opened

........

r41040 | raimue@… | 2008-10-21 13:06:39 +0200 (Tue, 21 Oct 2008) | 4 lines


macports/macport.tcl:

  • New flag "default" for sources to indicate fallback for resources (group)
  • Add parameter to getsourceconfigdir to get path for a requested file

........

r41042 | raimue@… | 2008-10-21 13:11:44 +0200 (Tue, 21 Oct 2008) | 3 lines


macports1.0/macports.tcl:
Rename getsourceconfigdir to getportresourcepath

........

r41043 | raimue@… | 2008-10-21 13:15:16 +0200 (Tue, 21 Oct 2008) | 3 lines


port1.0/portutil.tcl:
Use getportresourcepath for the group files

........

r41044 | raimue@… | 2008-10-21 13:19:47 +0200 (Tue, 21 Oct 2008) | 3 lines


port1.0/portlint.tcl:
Use getresourcepath for group files

........

r41045 | raimue@… | 2008-10-21 13:20:36 +0200 (Tue, 21 Oct 2008) | 3 lines


port1.0/portmain.tcl:
Add a note that we should get rid of $portresourcepath in favor of [getportresourcepath]

........

r41046 | raimue@… | 2008-10-21 13:40:29 +0200 (Tue, 21 Oct 2008) | 3 lines


port1.0/portutil.tcl:
Missed one instance of getsourceconfigdir

........

r41138 | raimue@… | 2008-10-25 20:52:50 +0200 (Sat, 25 Oct 2008) | 3 lines


port1.0/portutil.tcl:
Use getportresourcepath for global variant descriptions

........

r41139 | raimue@… | 2008-10-25 21:23:15 +0200 (Sat, 25 Oct 2008) | 3 lines


port1.0/portmain.tcl:
Correct XXX tag

........

r41142 | raimue@… | 2008-10-25 23:11:30 +0200 (Sat, 25 Oct 2008) | 3 lines


port1.0/portfetch.tcl:
Use getportresourcepath

........

r41143 | raimue@… | 2008-10-25 23:12:04 +0200 (Sat, 25 Oct 2008) | 3 lines


port1.0/portdestroot.tcl:
Use getportresourcepath

........

r41145 | raimue@… | 2008-10-26 00:04:15 +0200 (Sun, 26 Oct 2008) | 3 lines


macports1.0/macports.tcl:
Fix a problem with URLs not using the file protocol

........

r41151 | raimue@… | 2008-10-26 03:09:54 +0100 (Sun, 26 Oct 2008) | 3 lines


macports1.0/macports.tcl:
Fix issues introduced in r41145, the file exists check was wrong

........

r41403 | raimue@… | 2008-11-01 22:59:21 +0100 (Sat, 01 Nov 2008) | 3 lines


port1.0/portutil.tcl:
Add a debug output which group files are used

........

r41458 | blb@… | 2008-11-03 22:58:28 +0100 (Mon, 03 Nov 2008) | 2 lines


Add [default] tag and description to sources.conf

........

r41462 | blb@… | 2008-11-04 02:12:28 +0100 (Tue, 04 Nov 2008) | 2 lines


No longer need to install resources with base

........

r41463 | blb@… | 2008-11-04 02:14:49 +0100 (Tue, 04 Nov 2008) | 4 lines


Move the install/ subdir (containing the mtree files) into .../share/macports
from the resources dir (the mtree contains a bit of install-time info, so it
shouldn't be with the resources stuff in the port tree)

........

r42575 | blb@… | 2008-11-25 01:53:05 +0100 (Tue, 25 Nov 2008) | 3 lines


Add script to handle upgrades through configure/make/make install and
the package, so [default] is added as appropriate to sources.conf

........

r42626 | raimue@… | 2008-11-27 02:21:15 +0100 (Thu, 27 Nov 2008) | 3 lines


package1.0/portpkg.tcl, package1.0/portmpkg.tcl:
Remove portresourcepath and use [getportresourcepath] instead

........

r42640 | raimue@… | 2008-11-27 11:49:32 +0100 (Thu, 27 Nov 2008) | 3 lines


package1.0/portrpm.tcl, package1.0/portsrpm.tcl:
Remove reference to portresurcepath which is not used at all

........

r42641 | raimue@… | 2008-11-27 11:52:12 +0100 (Thu, 27 Nov 2008) | 3 lines


port1.0/portmain.tcl:
Remove definition of portresourcepath as it is not used any more

........

r42659 | raimue@… | 2008-11-28 16:44:30 +0100 (Fri, 28 Nov 2008) | 3 lines


macports1.0/macports.tcl:
Rename portresourcepath from .resources to _resources

........

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