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

Last change on this file since 89839 was 89839, checked in by jeremyhu@…, 7 years ago

Add an option to reinplace that will allow choosing a specific locale for sed to operate under.

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