root/trunk/base/src/port1.0/portutil.tcl

# -*- 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
# portutil.tcl
# $Id$
#
# Copyright (c) 2004 Robert Shaw <rshaw@opendarwin.org>
# Copyright (c) 2002 Apple Computer, Inc.
# Copyright (c) 2006, 2007 Markus W. Weissmann <mww@macports.org>
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright
#    notice, this list of conditions and the following disclaimer in the
#    documentation and/or other materials provided with the distribution.
# 3. Neither the name of Apple Computer, Inc. nor the names of its contributors
#    may be used to endorse or promote products derived from this software
#    without specific prior written permission.
# 
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#

package provide portutil 1.0
package require Pextlib 1.0
package require macports_dlist 1.0
package require macports_util 1.0
package require msgcat
package require porttrace 1.0

global targets target_uniqid all_variants

set targets [list]
set target_uniqid 0

set all_variants [list]

########### External High Level Procedures ###########

namespace eval options {
}

# option
# This is an accessor for Portfile options.  Targets may use
# this in the same style as the standard Tcl "set" procedure.
#   name  - the name of the option to read or write
#   value - an optional value to assign to the option

proc option {name args} {
    # XXX: right now we just transparently use globals
    # eventually this will need to bridge the options between
    # the Portfile's interpreter and the target's interpreters.
    global $name
    if {[llength $args] > 0} {
        ui_debug "setting option $name to $args"
        set $name [lindex $args 0]
    }
    return [set $name]
}

# exists
# This is an accessor for Portfile options.  Targets may use
# this procedure to test for the existence of a Portfile option.
#   name - the name of the option to test for existence

proc exists {name} {
    # XXX: right now we just transparently use globals
    # eventually this will need to bridge the options between
    # the Portfile's interpreter and the target's interpreters.
    global $name
    return [info exists $name]
}

##
# Handle an option
#
# @param option name of the option
# @param args arguments
proc handle_option {option args} {
    global $option user_options option_procs

    if {![info exists user_options($option)]} {
        set $option $args
    }
}

##
# Handle option-append
#
# @param option name of the option
# @param args arguments
proc handle_option-append {option args} {
    global $option user_options option_procs

    if {![info exists user_options($option)]} {
        if {[info exists $option]} {
            set $option [concat [set $option] $args]
        } else {
            set $option $args
        }
    }
}

##
# Handle option-delete
#
# @param option name of the option
# @param args arguments
proc handle_option-delete {option args} {
    global $option user_options option_procs

    if {![info exists user_options($option)] && [info exists $option]} {
        set temp [set $option]
        foreach val $args {
            set temp [ldelete $temp $val]
        }
        set $option $temp
    }
}

# options
# Exports options in an array as externally callable procedures
# Thus, "options name date" would create procedures named "name"
# and "date" that set global variables "name" and "date", respectively
# When an option is modified in any way, options::$option is called,
# if it exists
# Arguments: <list of options>
proc options {args} {
    foreach option $args {
        interp alias {} $option {} handle_option $option
        interp alias {} $option-append {} handle_option-append $option
        interp alias {} $option-delete {} handle_option-delete $option
    }
}

##
# Export options into PortInfo
#
# @param option the name of the option
# @param action set or delete
# @param value the value to be set, defaults to an empty string
proc options::export {option action {value ""}} {
    global $option PortInfo
    switch $action {
        set {
            set PortInfo($option) $value
        }
        delete {
            unset PortInfo($option)
        }
    }
}

##
# Export multiple options
#
# @param args list of ports to be exported
proc options_export {args} {
    foreach option $args {
        option_proc $option options::export
    }
}

##
# Registers a proc to be called when an option is changed
#
# @param option the name of the option
# @param args name of proc (and additional arguments)
proc option_proc {option args} {
    global option_procs $option
    if {[info exists option_procs($option)]} {
        set option_procs($option) [concat $option_procs($option) $args]
        # we're already tracing
    } else {
        set option_procs($option) $args
        trace add variable $option {read write unset} option_proc_trace
    }
}

# option_proc_trace
# trace handler for option reads. Calls option procedures with correct arguments.
proc option_proc_trace {optionName index op} {
    global option_procs
    upvar $optionName $optionName
    switch $op {
        write {
            foreach p $option_procs($optionName) {
                $p $optionName set [set $optionName]
            }
        }
        read {
            foreach p $option_procs($optionName) {
                $p $optionName read
            }
        }
        unset {
            foreach p $option_procs($optionName) {
                if {[catch {$p $optionName delete} result]} {
                    ui_debug "error during unset trace ($p): $result\n$::errorInfo"
                }
            }
            trace add variable $optionName {read write unset} option_proc_trace
        }
    }
}

# commands
# Accepts a list of arguments, of which several options are created
# and used to form a standard set of command options.
proc commands {args} {
    foreach option $args {
        options use_${option} ${option}.dir ${option}.pre_args ${option}.args ${option}.post_args ${option}.env ${option}.type ${option}.cmd
    }
}

# Given a command name, assemble a command string
# composed of the command options.
proc command_string {command} {
    global ${command}.dir ${command}.pre_args ${command}.args ${command}.post_args ${command}.cmd
    
    if {[info exists ${command}.dir]} {
        append cmdstring "cd \"[set ${command}.dir]\" &&"
    }
    
    if {[info exists ${command}.cmd]} {
        foreach string [set ${command}.cmd] {
            append cmdstring " $string"
        }
    } else {
        append cmdstring " ${command}"
    }

    foreach var "${command}.pre_args ${command}.args ${command}.post_args" {
        if {[info exists $var]} {
            foreach string [set ${var}] {
                append cmdstring " ${string}"
            }
        }
    }

    ui_debug "Assembled command: '$cmdstring'"
    return $cmdstring
}

# Given a command name, execute it with the options.
# command_exec command [-notty] [command_prefix [command_suffix]]
# command           name of the command
# command_prefix    additional command prefix (typically pipe command)
# command_suffix    additional command suffix (typically redirection)
proc command_exec {command args} {
    global ${command}.env ${command}.env_array env
    set notty 0
    set command_prefix ""
    set command_suffix ""

    if {[llength $args] > 0} {
        if {[lindex $args 0] == "-notty"} {
            set notty 1
            set args [lrange $args 1 end]
        }

        if {[llength $args] > 0} {
            set command_prefix [lindex $args 0]
            if {[llength $args] > 1} {
                set command_suffix [lindex $args 1]
            }
        }
    }
    
    # Set the environment.
    # If the array doesn't exist, we create it with the value
    # coming from ${command}.env
    # Otherwise, it means the caller actually played with the environment
    # array already (e.g. configure flags).
    if {![array exists ${command}.env_array]} {
        parse_environment ${command}
    }
    if {[option macosx_deployment_target] ne ""} {
        set ${command}.env_array(MACOSX_DEPLOYMENT_TARGET) [option macosx_deployment_target]
    }
    
    # Debug that.
    ui_debug "Environment: [environment_array_to_string ${command}.env_array]"

    # Get the command string.
    set cmdstring [command_string ${command}]
    
    # Call this command.
    # TODO: move that to the system native call?
    # Save the environment.
    array set saved_env [array get env]
    # Set the overriden variables from the portfile.
    array set env [array get ${command}.env_array]
    # Call the command.
    set fullcmdstring "$command_prefix $cmdstring $command_suffix"
    if {$notty} {
        set code [catch {system -notty $fullcmdstring} result]
    } else {
        set code [catch {system $fullcmdstring} result]
    }
    # Unset the command array until next time.
    array unset ${command}.env_array
    
    # Restore the environment.
    array unset env *
    unsetenv *
    array set env [array get saved_env]

    # Return as if system had been called directly. 
    return -code $code $result
}

# default
# Sets a variable to the supplied default if it does not exist,
# and adds a variable trace. The variable traces allows for delayed
# variable and command expansion in the variable's default value.
proc default {option val} {
    global $option option_defaults
    if {[info exists option_defaults($option)]} {
        ui_debug "Re-registering default for $option"
        # remove the old trace
        trace vdelete $option rwu default_check
    } else {
        # If option is already set and we did not set it
        # do not reset the value
        if {[info exists $option]} {
            return
        }
    }
    set option_defaults($option) $val
    set $option $val
    trace variable $option rwu default_check
}

# default_check
# trace handler to provide delayed variable & command expansion
# for default variable values
proc default_check {optionName index op} {
    global option_defaults $optionName
    switch $op {
        w {
            unset option_defaults($optionName)
            trace vdelete $optionName rwu default_check
            return
        }
        r {
            upvar $optionName option
            uplevel #0 set $optionName $option_defaults($optionName)
            return
        }
        u {
            unset option_defaults($optionName)
            trace vdelete $optionName rwu default_check
            return
        }
    }
}

# variant <provides> [<provides> ...] [requires <requires> [<requires>]]
# Portfile level procedure to provide support for declaring variants
proc variant {args} {
    global all_variants PortInfo porturl

    # Each key in PortInfo(vinfo) maps to an array which contains the
    # following keys:
    #   * conflicts
    #   * description: This key's mapping is duplicated in
    #                  PortInfo(variant_desc) for backward compatibility
    #                  reasons (specifically 1.7.0's format of PortIndex).
    #   * is_default: This key exists iff the variant is a default variant.
    #   * requires
    if {![info exists PortInfo(vinfo)]} {
        set PortInfo(vinfo) {}
    }
    array set vinfo $PortInfo(vinfo)

    set len [llength $args]
    set code [lindex $args end]
    set args [lrange $args 0 [expr $len - 2]]
    
    set ditem [variant_new "temp-variant"]
    
    # mode indicates what the arg is interpreted as.
    # possible mode keywords are: requires, conflicts, provides
    # The default mode is provides.  Arguments are added to the
    # most recently specified mode (left to right).
    set mode "provides"
    foreach arg $args {
        switch -exact $arg {
            description -
            provides -
            requires -
            conflicts { set mode $arg }
            default { ditem_append $ditem $mode $arg }      
        }
    }
    ditem_key $ditem name "[join [ditem_key $ditem provides] -]"

    # make a user procedure named variant-blah-blah
    # we will call this procedure during variant-run
    makeuserproc "variant-[ditem_key $ditem name]" \{$code\}
    
    # Export provided variant to PortInfo
    # (don't list it twice if the variant was already defined, which can happen
    # with universal or group code).
    set variant_provides [ditem_key $ditem provides]
    if {[variant_exists $variant_provides]} {
        # This variant was already defined. Remove it from the dlist.
        variant_remove_ditem $variant_provides
    } else {
        # Create an array to contain the variant's information.
        if {![info exists vinfo($variant_provides)]} {
            set vinfo($variant_provides) {}
        }
        array set variant $vinfo($variant_provides)
    
        # Set conflicts.
        set vconflicts [join [lsort [ditem_key $ditem conflicts]]]
        if {$vconflicts ne ""} {
            array set variant [list conflicts $vconflicts]
        }

        lappend PortInfo(variants) $variant_provides
        set vdesc [join [ditem_key $ditem description]]

        # read global variant description, if none given
        if {$vdesc == ""} {
            set vdesc [variant_desc $porturl $variant_provides]
        }

        # Set description.
        if {$vdesc ne ""} {
            array set variant [list description $vdesc]
            # XXX: The following line should be removed after 1.8.0 is
            #      released.
            lappend PortInfo(variant_desc) $variant_provides $vdesc
        }

        # Set requires.
        set vrequires [join [lsort [ditem_key $ditem requires]]]
        if {$vrequires ne ""} {
            array set variant [list requires $vrequires]
        }
    }

    # Add the variant (back) to PortInfo(vinfo).
    array set vinfo [list $variant_provides [array get variant]]
    set PortInfo(vinfo) [array get vinfo]

    # Finally append the ditem to the dlist.
    lappend all_variants $ditem
}

# variant_isset name
# Returns 1 if variant name selected, otherwise 0
proc variant_isset {name} {
    global variations
    
    if {[info exists variations($name)] && $variations($name) == "+"} {
        return 1
    }
    return 0
}

# variant_set name
# Sets variant to run for current portfile
proc variant_set {name} {
    global variations
    set variations($name) +
}

# variant_unset name
# Clear variant for current portfile
proc variant_unset {name} {
    global variations
    
    set variations($name) -
}

# variant_undef name
# Undefine a variant for the current portfile.
proc variant_undef {name} {
    global variations PortInfo
    
    # Remove it from the list of selected variations.
    array unset variations $name

    # Remove the variant from the portinfo.
    if {[info exists PortInfo(variants)]} {
        set variant_index [lsearch -exact $PortInfo(variants) $name]
        if {$variant_index >= 0} {
            set new_list [lreplace $PortInfo(variants) $variant_index $variant_index]
            if {"$new_list" == {}} {
                unset PortInfo(variants) 
            } else {
                set PortInfo(variants) $new_list
            }
        }
    }
    
    # And from the dlist.
    variant_remove_ditem $name
}

# variant_remove_ditem name
# Remove variant name's ditem from the all_variants dlist
proc variant_remove_ditem {name} {
    global all_variants
    set item_index 0
    foreach variant_item $all_variants {
        set item_provides [ditem_key $variant_item provides]
        if {$item_provides == $name} {
            set all_variants [lreplace $all_variants $item_index $item_index]
            break
        }
        
        incr item_index
    }
}

# variant_exists name
# determine if a variant exists.
proc variant_exists {name} {
    global PortInfo
    if {[info exists PortInfo(variants)] &&
      [lsearch -exact $PortInfo(variants) $name] >= 0} {
        return 1
    }

    return 0
}

##
# Get description for a variant from global descriptions file
#
# @param porturl url to a port
# @param variant name
# @return description from descriptions file or an empty string
proc variant_desc {porturl variant} {
    global variant_descs_global

    set descfile [getportresourcepath $porturl "port1.0/variant_descriptions.conf"]
    if {![info exists variant_descs_global($descfile)]} {
        set variant_descs_global($descfile) yes

        if {[file exists $descfile]} {
            if {[catch {set fd [open $descfile r]} err]} {
                ui_warn "Could not open global variant description file: $err"
                return ""
            }
            set lineno 0
            while {[gets $fd line] >= 0} {
                incr lineno
                set name [lindex $line 0]
                set desc [lindex $line 1]
                if {$name != "" && $desc != ""} {
                    set variant_descs_global(${descfile}_$name) $desc
                } else {
                    ui_warn "Invalid variant description in $descfile at line $lineno"
                }
            }
            close $fd
        }
    }

    if {[info exists variant_descs_global(${descfile}_${variant})]} {
        return $variant_descs_global(${descfile}_${variant})
    } else {
        return ""
    }
}

# platform <os> [<release>] [<arch>] 
# Portfile level procedure to provide support for declaring platform-specifics
# Basically, just wrap 'variant', so that Portfiles' platform declarations can
# be more readable, and support arch and version specifics
proc platform {args} {
    global all_variants PortInfo os.platform os.arch os.version os.major
    
    set len [llength $args]
    set code [lindex $args end]
    set os [lindex $args 0]
    set args [lrange $args 1 [expr $len - 2]]
    
    set ditem [variant_new "temp-variant"]
    
    foreach arg $args {
        if {[regexp {(^[0-9]+$)} $arg match result]} {
            set release $result
        } elseif {[regexp {([a-zA-Z0-9]*)} $arg match result]} {
            set arch $result
        }
    }
    
    # Add the variant for this platform
    set platform $os
    if {[info exists release]} { set platform ${platform}_${release} }
    if {[info exists arch]} { set platform ${platform}_${arch} }
    
    # Pick up a unique name.
    if {[variant_exists $platform]} {
        set suffix 1
        while {[variant_exists "$platform-$suffix"]} {
            incr suffix
        }
        
        set platform "$platform-$suffix"
    }
    variant $platform $code
    
    # Set the variant if this platform matches the platform we're on
    set matches 1
    if {[info exists os.platform] && ${os.platform} == $os} { 
        set sel_platform $os
        if {[info exists os.major] && [info exists release]} {
            if {${os.major} == $release } { 
                set sel_platform ${sel_platform}_${release} 
            } else {
                set matches 0
            }
        }
        if {$matches == 1 && [info exists arch] && [info exists os.arch]} {
            if {${os.arch} == $arch} {
                set sel_platform ${sel_platform}_${arch}
            } else {
                set matches 0
            }
        }
        if {$matches == 1} {
            variant_set $sel_platform
        }
    }
}

########### Environment utility functions ###########

# Parse the environment string of a command, storing the values into the
# associated environment array.
proc parse_environment {command} {
    global ${command}.env ${command}.env_array

    if {[info exists ${command}.env]} {
        # Flatten the environment string.
        set the_environment [join [set ${command}.env]]
    
        while {[regexp "^(?: *)(\[^= \]+)=(\"|'|)(\[^\"'\]*?)\\2(?: +|$)(.*)$" ${the_environment} matchVar key delimiter value remaining]} {
            set the_environment ${remaining}
            set ${command}.env_array(${key}) ${value}
        }
    } else {
        array set ${command}.env_array {}
    }
}

# Append to the value in the parsed environment.
# Leave the environment untouched if the value is empty.
proc append_to_environment_value {command key value} {
    global ${command}.env_array

    if {[string length $value] == 0} {
        return
    }

    # Parse out any delimiter.
    set append_value $value
    if {[regexp {^("|')(.*)\1$} $append_value matchVar append_delim matchedValue]} {
        set append_value $matchedValue
    }

    if {[info exists ${command}.env_array($key)]} {
        set original_value [set ${command}.env_array($key)]
        set ${command}.env_array($key) "${original_value} ${append_value}"
    } else {
        set ${command}.env_array($key) $append_value
    }
}

# Append several items to a value in the parsed environment.
proc append_list_to_environment_value {command key vallist} {
    foreach {value} $vallist {
        append_to_environment_value ${command} $key $value
    }
}

# Build the environment as a string.
# Remark: this method is only used for debugging purposes.
proc environment_array_to_string {environment_array} {
    upvar 1 ${environment_array} env_array
    
    set theString ""
    foreach {key value} [array get env_array] {
        if {$theString == ""} {
            set theString "$key='$value'"
        } else {
            set theString "${theString} $key='$value'"
        }
    }
    
    return $theString
}

########### Distname utility functions ###########

# Given a distribution file name, return the appended tag
# Example: getdisttag distfile.tar.gz:tag1 returns "tag1"
# / isn't included in the regexp, thus allowing port specification in URLs.
proc getdisttag {name} {
    if {[regexp {.+:([0-9A-Za-z_-]+)$} $name match tag]} {
        return $tag
    } else {
        return ""
    }
}

# Given a distribution file name, return the name without an attached tag
# Example : getdistname distfile.tar.gz:tag1 returns "distfile.tar.gz"
# / isn't included in the regexp, thus allowing port specification in URLs.
proc getdistname {name} {
    regexp {(.+):[0-9A-Za-z_-]+$} $name match name
    return $name
}


########### Misc Utility Functions ###########

# tbool (testbool)
# If the variable exists in the calling procedure's namespace