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

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

portutil.tcl, in [command_string]:

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