source: branches/gsoc09-logging/base/src/port1.0/portutil.tcl @ 52218

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

Merge from trunk

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