source: branches/gsoc08-privileges/base/src/port1.0/portutil.tcl @ 38144

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

Added a new procedure for recursive chowning of directories. Inserted calls to this procedure where necessary.

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