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

Last change on this file since 34513 was 34513, checked in by afb@…, 10 years ago

add target_state variable patch from raimue, for targets that don't need state (#13458)

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