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

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

Fix for Ticket #8221: respect variants when determining dependencies to upgrade

There are two key elements to this fix. First, we make sure that the
Portfile of the port to be upgraded is read via mportopen and then
portinfo is updated via mportinfo, prior to the dependency
information ever being used. (Formerly, the portfile was only
sometimes opened, and even when it was, the portinfo was not
refreshed.) Second, wait until after the existing variants in the
installed version have been determined before merging in
variants.conf, so that the installed variants take precedence. The
command line still trumps everything, of course.

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