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

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

Finally merging the dp2mp-move branch into trunk, woot!

This basically means all strings in our sources,
whether it's something we output to the user or something
internal, such as a function/proc naming, are entirely in
the macports namespace and we no longer mix darwinports
with apple with macports strings.

It also means we now have new paths in svn and on
the client side at installation time, added to a
cleaner structure under ${prefix}/var/. Read
http://trac.macports.org/projects/macports/wiki/MacPortsRenaming
for more information.

NOTE: This commit also marks the rsync server finally
being moved over to the macosforge boxes, with the new
layout outlined in the dp2mp-move branch in place.
DNS entries still point to the old rsync server for
macports, however, so sync'ing/selfupdating an installation
based on these sources will be temporarily broken
until dns refresh.

To developers and testers, please do test the upgrade
target in the main base/Makefile as thouroughly as
possible and report any bugs/shortcomings/unexpected_behavior
to me, thanks!

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 55.4 KB
Line 
1# et:ts=4
2# portutil.tcl
3# $Id: portutil.tcl 26177 2007-06-15 10:11:22Z jmpp@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}.env ${command}.type ${command}.cmd
219   
220    set cmdstring ""
221    if {[info exists ${command}.dir]} {
222        set cmdstring "cd \"[set ${command}.dir]\" &&"
223    }
224   
225    if {[info exists ${command}.cmd]} {
226        foreach string [set ${command}.cmd] {
227            set cmdstring "$cmdstring $string"
228        }
229    } else {
230        set cmdstring "$cmdstring ${command}"
231    }
232    foreach var "${command}.pre_args ${command}.args ${command}.post_args" {
233        if {[info exists $var]} {
234            foreach string [set ${var}] {
235                set cmdstring "$cmdstring $string"
236            }
237        }
238    }
239    ui_debug "Assembled command: '$cmdstring'"
240    return $cmdstring
241}
242
243# Given a command name, execute it with the options.
244# command_exec command [-notty] [command_prefix [command_suffix]]
245# command                       name of the command
246# command_prefix        additional command prefix (typically pipe command)
247# command_suffix        additional command suffix (typically redirection)
248proc command_exec {command args} {
249        global ${command}.env ${command}.env_array env
250        set notty 0
251        set command_prefix ""
252        set command_suffix ""
253
254        if {[llength $args] > 0} {
255                if {[lindex $args 0] == "-notty"} {
256                        set notty 1
257                        set args [lrange $args 1 end]
258                }
259
260                if {[llength $args] > 0} {
261                        set command_prefix [lindex $args 0]
262                        if {[llength $args] > 1} {
263                                set command_suffix [lindex $args 1]
264                        }
265                }
266        }
267       
268        # Set the environment.
269        # If the array doesn't exist, we create it with the value
270        # coming from ${command}.env
271        # Otherwise, it means the caller actually played with the environment
272        # array already (e.g. configure flags).
273        if {![array exists ${command}.env_array]} {
274                parse_environment ${command}
275        }
276       
277        # Debug that.
278    ui_debug "Environment: [environment_array_to_string ${command}.env_array]"
279
280        # Get the command string.
281        set cmdstring [command_string ${command}]
282       
283        # Call this command.
284        # TODO: move that to the system native call?
285        # Save the environment.
286        array set saved_env [array get env]
287        # Set the overriden variables from the portfile.
288        array set env [array get ${command}.env_array]
289        # Call the command.
290        set fullcmdstring "$command_prefix $cmdstring $command_suffix"
291        if {$notty} {
292                set code [catch {system -notty $fullcmdstring} result]
293        } else {
294                set code [catch {system $fullcmdstring} result]
295        }
296        # Unset the command array until next time.
297        array unset ${command}.env_array
298       
299        # Restore the environment.
300        array unset env *
301        array set env [array get saved_env]
302
303        # Return as if system had been called directly.
304        return -code $code $result
305}
306
307# default
308# Sets a variable to the supplied default if it does not exist,
309# and adds a variable trace. The variable traces allows for delayed
310# variable and command expansion in the variable's default value.
311proc default {option val} {
312    global $option option_defaults
313    if {[info exists option_defaults($option)]} {
314        ui_debug "Re-registering default for $option"
315        # remove the old trace
316        trace vdelete $option rwu default_check
317    } else {
318        # If option is already set and we did not set it
319        # do not reset the value
320        if {[info exists $option]} {
321            return
322        }
323    }
324    set option_defaults($option) $val
325    set $option $val
326    trace variable $option rwu default_check
327}
328
329# default_check
330# trace handler to provide delayed variable & command expansion
331# for default variable values
332proc default_check {optionName index op} {
333    global option_defaults $optionName
334    switch $op {
335        w {
336            unset option_defaults($optionName)
337            trace vdelete $optionName rwu default_check
338            return
339        }
340        r {
341            upvar $optionName option
342            uplevel #0 set $optionName $option_defaults($optionName)
343            return
344        }
345        u {
346            unset option_defaults($optionName)
347            trace vdelete $optionName rwu default_check
348            return
349        }
350    }
351}
352
353# variant <provides> [<provides> ...] [requires <requires> [<requires>]]
354# Portfile level procedure to provide support for declaring variants
355proc variant {args} {
356    global all_variants PortInfo
357   
358    set len [llength $args]
359    set code [lindex $args end]
360    set args [lrange $args 0 [expr $len - 2]]
361   
362    set ditem [variant_new "temp-variant"]
363   
364    # mode indicates what the arg is interpreted as.
365    # possible mode keywords are: requires, conflicts, provides
366    # The default mode is provides.  Arguments are added to the
367    # most recently specified mode (left to right).
368    set mode "provides"
369    foreach arg $args {
370        switch -exact $arg {
371            description -
372            provides -
373            requires -
374            conflicts { set mode $arg }
375            default { ditem_append $ditem $mode $arg }         
376        }
377    }
378    ditem_key $ditem name "[join [ditem_key $ditem provides] -]"
379   
380    # make a user procedure named variant-blah-blah
381    # we will call this procedure during variant-run
382    makeuserproc "variant-[ditem_key $ditem name]" \{$code\}
383   
384    # Export provided variant to PortInfo
385    # (don't list it twice if the variant was already defined, which can happen
386    # with universal or group code).
387    set variant_provides [ditem_key $ditem provides]
388    if {[variant_exists $variant_provides]} {
389                # This variant was already defined. Remove it from the dlist.
390                variant_remove_ditem $variant_provides
391        } else {
392            lappend PortInfo(variants) $variant_provides
393            set vdesc [join [ditem_key $ditem description]]
394            if {$vdesc != ""} {
395                    lappend PortInfo(variant_desc) $variant_provides $vdesc
396                }
397        }
398
399        # Finally append the ditem to the dlist.
400    lappend all_variants $ditem
401}
402
403# variant_isset name
404# Returns 1 if variant name selected, otherwise 0
405proc variant_isset {name} {
406    global variations
407   
408    if {[info exists variations($name)] && $variations($name) == "+"} {
409        return 1
410    }
411    return 0
412}
413
414# variant_set name
415# Sets variant to run for current portfile
416proc variant_set {name} {
417    global variations
418   
419    set variations($name) +
420}
421
422# variant_unset name
423# Clear variant for current portfile
424proc variant_unset {name} {
425    global variations
426   
427    set variations($name) -
428}
429
430# variant_undef name
431# Undefine a variant for the current portfile.
432proc variant_undef {name} {
433    global variations PortInfo
434   
435    # Remove it from the list of selected variations.
436    array unset variations $name
437
438        # Remove the variant from the portinfo.
439        if {[info exists PortInfo(variants)]} {
440                set variant_index [lsearch -exact $PortInfo(variants) $name]
441                if {$variant_index >= 0} {
442                        set new_list [lreplace $PortInfo(variants) $variant_index $variant_index]
443                        if {"$new_list" == {}} {
444                                unset PortInfo(variants) 
445                        } else {
446                                set PortInfo(variants) $new_list
447                        }
448                }
449        }
450       
451        # And from the dlist.
452        variant_remove_ditem $name
453}
454
455# variant_remove_ditem name
456# Remove variant name's ditem from the all_variants dlist
457proc variant_remove_ditem {name} {
458        global all_variants
459        set item_index 0
460        foreach variant_item $all_variants {
461                set item_provides [ditem_key $variant_item provides]
462                if {$item_provides == $name} {
463                        set all_variants [lreplace $all_variants $item_index $item_index]
464                        break
465                }
466               
467                incr item_index
468        }
469}
470
471# variant_exists name
472# determine if a variant exists.
473proc variant_exists {name} {
474        global PortInfo
475        if {[info exists PortInfo(variants)] &&
476                [lsearch -exact $PortInfo(variants) $name] >= 0} {
477                return 1
478        }
479       
480        return 0
481}
482
483# platform <os> [<release>] [<arch>]
484# Portfile level procedure to provide support for declaring platform-specifics
485# Basically, just wrap 'variant', so that Portfiles' platform declarations can
486# be more readable, and support arch and version specifics
487proc platform {args} {
488    global all_variants PortInfo os.platform os.arch os.version
489   
490    set len [llength $args]
491    set code [lindex $args end]
492    set os [lindex $args 0]
493    set args [lrange $args 1 [expr $len - 2]]
494   
495    set ditem [variant_new "temp-variant"]
496   
497    foreach arg $args {
498        if {[regexp {(^[0-9]$)} $arg match result]} {
499            set release $result
500        } elseif {[regexp {([a-zA-Z0-9]*)} $arg match result]} {
501            set arch $result
502        }
503    }
504   
505    # Add the variant for this platform
506    set platform $os
507    if {[info exists release]} { set platform ${platform}_${release} }
508    if {[info exists arch]} { set platform ${platform}_${arch} }
509   
510    # Pick up a unique name.
511    if {[variant_exists $platform]} {
512        set suffix 1
513        while {[variant_exists "$platform-$suffix"]} {
514                incr suffix
515        }
516       
517        set platform "$platform-$suffix"
518    }
519    variant $platform $code
520   
521    # Set the variant if this platform matches the platform we're on
522    set matches 1
523    if {[info exists os.platform] && ${os.platform} == $os} { 
524        set sel_platform $os
525        if {[info exists os.version] && [info exists release]} {
526            regexp {([0-9]*)[0-9\.]?} ${os.version} match major
527            if {$major == $release } { 
528                set sel_platform ${sel_platform}_${release} 
529            } else {
530                    set matches 0
531            }
532        }
533        if {$matches == 1 && [info exists arch] && [info exists os.arch]} {
534                if {${os.arch} == $arch} {
535                        set sel_platform ${sel_platform}_${arch}
536                } else {
537                        set matches 0
538                }
539    }
540    if {$matches == 1} {
541        variant_set $sel_platform
542    }
543    }
544}
545
546########### Environment utility functions ###########
547
548# Parse the environment string of a command, storing the values into the
549# associated environment array.
550proc parse_environment {command} {
551        global ${command}.env ${command}.env_array
552
553        if {[info exists ${command}.env]} {
554                # Flatten the environment string.
555                set the_environment ""
556                foreach str [set ${command}.env] {
557                        set the_environment "$the_environment $str"
558                }
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 sed
706        if {$extended} {
707            lappend cmdline -E
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                        if {([info exists ports_trace]
1100                                && $ports_trace == "yes"
1101                                && $target != "clean")} {
1102                                trace_start $workpath
1103
1104                                # Enable the fence to prevent any creation/modification
1105                                # outside the sandbox.
1106                                if {$target != "activate"
1107                                        && $target != "archive"
1108                                        && $target != "fetch"
1109                                        && $target != "install"} {
1110                                        trace_enable_fence
1111                                }
1112                        }
1113
1114                        # Execute pre-run procedure
1115                        if {[ditem_contains $ditem prerun]} {
1116                        set result [catch {[ditem_key $ditem prerun] $name} errstr]
1117                        }
1118                       
1119                        if {$result == 0} {
1120                        foreach pre [ditem_key $ditem pre] {
1121                                ui_debug "Executing $pre"
1122                                set result [catch {$pre $name} errstr]
1123                                if {$result != 0} { break }
1124                        }
1125                        }
1126                       
1127                        if {$result == 0} {
1128                        ui_debug "Executing $name ($portname)"
1129                        set result [catch {$procedure $name} errstr]
1130                        }
1131                       
1132                        if {$result == 0} {
1133                        foreach post [ditem_key $ditem post] {
1134                                ui_debug "Executing $post"
1135                                set result [catch {$post $name} errstr]
1136                                if {$result != 0} { break }
1137                        }
1138                        }
1139                        # Execute post-run procedure
1140                        if {[ditem_contains $ditem postrun] && $result == 0} {
1141                        set postrun [ditem_key $ditem postrun]
1142                        ui_debug "Executing $postrun"
1143                        set result [catch {$postrun $name} errstr]
1144                        }
1145
1146                        # Check dependencies & file creations outside workpath.
1147                        if {[info exists ports_trace]
1148                                && $ports_trace == "yes"
1149                                && $target != "clean"} {
1150                               
1151                                # Don't check dependencies for extract (they're not honored
1152                                # anyway). This avoids warnings about bzip2.
1153                                if {$target != "extract"} {
1154                                        set depends {}
1155                                        set deptypes {}
1156                                       
1157                                        # Determine deptypes to look for based on target
1158                                        switch $target {
1159                                                configure       { set deptypes "depends_lib" }
1160                                               
1161                                                build           { set deptypes "depends_lib depends_build" }
1162                                               
1163                                                test            -
1164                                                destroot        -
1165                                                install         -
1166                                                archive         -
1167                                                pkg                     -
1168                                                mpkg            -
1169                                                rpmpackage      -
1170                                                dpkg            -
1171                                                activate    -
1172                                                ""                      { set deptypes "depends_lib depends_build depends_run" }
1173                                        }
1174                                       
1175                                        # Gather the dependencies for deptypes
1176                                        foreach deptype $deptypes {
1177                                                # Add to the list of dependencies if the option exists and isn't empty.
1178                                                if {[info exists PortInfo($deptype)] && $PortInfo($deptype) != ""} {
1179                                                        set depends [concat $depends $PortInfo($deptype)]
1180                                                }
1181                                        }
1182       
1183                                        # Dependencies are in the form verb:[param:]port
1184                                        set depsPorts {}
1185                                        foreach depspec $depends {
1186                                                # grab the portname portion of the depspec
1187                                                set dep_portname [lindex [split $depspec :] end]
1188                                                lappend depsPorts $dep_portname
1189                                        }
1190                                        trace_check_deps $target $depsPorts
1191                                }
1192                               
1193                                trace_check_violations
1194                               
1195                                # End of trace.
1196                                trace_stop
1197                        }
1198                }
1199        }
1200        if {$result == 0} {
1201                # Only write to state file if:
1202                # - we indeed performed this step.
1203                # - this step is not to always be performed
1204                # - this step must be written to file
1205                if {$skipped == 0
1206            && [ditem_key $ditem runtype] != "always"
1207            && [ditem_key $ditem state] != "no"} {
1208                write_statefile target $name $target_state_fd
1209            }
1210        } else {
1211            ui_error "Target $name returned: $errstr"
1212            set result 1
1213        }
1214       
1215    } else {
1216        ui_info "Warning: $name does not have a registered procedure"
1217        set result 1
1218    }
1219   
1220    return $result
1221}
1222
1223proc eval_targets {target} {
1224    global targets target_state_fd portname
1225    set dlist $targets
1226   
1227    # Select the subset of targets under $target
1228    if {$target != ""} {
1229        set matches [dlist_search $dlist provides $target]
1230       
1231        if {[llength $matches] > 0} {
1232            set dlist [dlist_append_dependents $dlist [lindex $matches 0] [list]]
1233            # Special-case 'all'
1234        } elseif {$target != "all"} {
1235            ui_error "unknown target: $target"
1236            return 1
1237        }
1238    }
1239   
1240    # Restore the state from a previous run.
1241    set target_state_fd [open_statefile]
1242   
1243    set dlist [dlist_eval $dlist "" target_run]
1244   
1245    if {[llength $dlist] > 0} {
1246        # somebody broke!
1247        set errstring "Warning: the following items did not execute (for $portname):"
1248        foreach ditem $dlist {
1249            append errstring " [ditem_key $ditem name]"
1250        }
1251        ui_info $errstring
1252        set result 1
1253    } else {
1254        set result 0
1255    }
1256   
1257    close $target_state_fd
1258    return $result
1259}
1260
1261# open_statefile
1262# open file to store name of completed targets
1263proc open_statefile {args} {
1264    global workpath worksymlink place_worksymlink portname portpath ports_ignore_older
1265   
1266    if {![file isdirectory $workpath]} {
1267        file mkdir $workpath
1268    }
1269    # flock Portfile
1270    set statefile [file join $workpath .macports.${portname}.state]
1271    if {[file exists $statefile]} {
1272        if {![file writable $statefile]} {
1273            return -code error "$statefile is not writable - check permission on port directory"
1274        }
1275        if {!([info exists ports_ignore_older] && $ports_ignore_older == "yes") && [file mtime $statefile] < [file mtime ${portpath}/Portfile]} {
1276            ui_msg "Portfile changed since last build; discarding previous state."
1277            #file delete $statefile
1278            exec rm -rf [file join $workpath]
1279            exec mkdir [file join $workpath]
1280        }
1281    }
1282
1283    # Create a symlink to the workpath for port authors
1284    if {[tbool place_worksymlink] && ![file isdirectory $worksymlink]} {
1285            exec ln -sf $workpath $worksymlink
1286    }
1287   
1288    set fd [open $statefile a+]
1289    if {[catch {flock $fd -exclusive -noblock} result]} {
1290        if {"$result" == "EAGAIN"} {
1291            ui_msg "Waiting for lock on $statefile"
1292        } elseif {"$result" == "EOPNOTSUPP"} {
1293            # Locking not supported, just return
1294            return $fd
1295        } else {
1296            return -code error "$result obtaining lock on $statefile"
1297        }
1298    }
1299    flock $fd -exclusive
1300    return $fd
1301}
1302
1303# check_statefile
1304# Check completed/selected state of target/variant $name
1305proc check_statefile {class name fd} {
1306    seek $fd 0
1307    while {[gets $fd line] >= 0} {
1308        if {$line == "$class: $name"} {
1309            return 1
1310        }
1311    }
1312    return 0
1313}
1314
1315# write_statefile
1316# Set target $name completed in the state file
1317proc write_statefile {class name fd} {
1318    if {[check_statefile $class $name $fd]} {
1319        return 0
1320    }
1321    seek $fd 0 end
1322    puts $fd "$class: $name"
1323    flush $fd
1324}
1325
1326# check_statefile_variants
1327# Check that recorded selection of variants match the current selection
1328proc check_statefile_variants {variations fd} {
1329    upvar $variations upvariations
1330   
1331    seek $fd 0
1332    while {[gets $fd line] >= 0} {
1333        if {[regexp "variant: (.*)" $line match name]} {
1334            set oldvariations([string range $name 1 end]) [string range $name 0 0]
1335        }
1336    }
1337   
1338    set mismatch 0
1339    if {[array size oldvariations] > 0} {
1340        if {[array size oldvariations] != [array size upvariations]} {
1341            set mismatch 1
1342        } else {
1343            foreach key [array names upvariations *] {
1344                if {![info exists oldvariations($key)] || $upvariations($key) != $oldvariations($key)} {
1345                    set mismatch 1
1346                    break
1347                }
1348            }
1349        }
1350    }
1351   
1352    return $mismatch
1353}
1354
1355########### Port Variants ###########
1356
1357# Each variant which provides a subset of the requested variations
1358# will be chosen.  Returns a list of the selected variants.
1359proc choose_variants {dlist variations} {
1360    upvar $variations upvariations
1361   
1362    set selected [list]
1363   
1364    foreach ditem $dlist {
1365        # Enumerate through the provides, tallying the pros and cons.
1366        set pros 0
1367        set cons 0
1368        set ignored 0
1369        foreach flavor [ditem_key $ditem provides] {
1370            if {[info exists upvariations($flavor)]} {
1371                if {$upvariations($flavor) == "+"} {
1372                    incr pros
1373                } elseif {$upvariations($flavor) == "-"} {
1374                    incr cons
1375                }
1376            } else {
1377                incr ignored
1378            }
1379        }
1380       
1381        if {$cons > 0} { continue }
1382       
1383        if {$pros > 0 && $ignored == 0} {
1384            lappend selected $ditem
1385        }
1386    }
1387    return $selected
1388}
1389
1390proc variant_run {ditem} {
1391    set name [ditem_key $ditem name]
1392    ui_debug "Executing variant $name provides [ditem_key $ditem provides]"
1393   
1394    # test for conflicting variants
1395    foreach v [ditem_key $ditem conflicts] {
1396        if {[variant_isset $v]} {
1397            ui_error "Variant $name conflicts with $v"
1398            return 1
1399        }
1400    }
1401   
1402    # execute proc with same name as variant.
1403    if {[catch "variant-${name}" result]} {
1404        global errorInfo
1405        ui_debug "$errorInfo"
1406        ui_error "Error executing $name: $result"
1407        return 1
1408    }
1409    return 0
1410}
1411
1412# Given a list of variant specifications, return a canonical string form
1413# for the registry.
1414    # The strategy is as follows: regardless of how some collection of variants
1415    # was turned on or off, a particular instance of the port is uniquely
1416    # characterized by the set of variants that are *on*. Thus, record those
1417    # variants in a string in a standard order as +var1+var2 etc.
1418    # We can skip the platform and architecture since those are always
1419    # requested.  XXX: Is that really true? What if the user explicitly
1420    # overrides the platform and architecture variants? Will the registry get
1421    # bollixed? It would seem safer to me to just leave in all the variants that
1422    # are on, but for now I'm just leaving the skipping code as it was in the
1423    # previous version.
1424proc canonicalize_variants {variants} {
1425    array set vara $variants
1426    set result ""
1427    set vlist [lsort -ascii [array names vara]]
1428    foreach v $vlist {
1429        if {$vara($v) == "+" && $v ne [option os.platform] && $v ne [option os.arch]} {
1430            append result +$v
1431        }
1432    }
1433    return $result
1434}
1435
1436proc eval_variants {variations} {
1437    global all_variants ports_force PortInfo portvariants
1438    set dlist $all_variants
1439    upvar $variations upvariations
1440    set chosen [choose_variants $dlist upvariations]
1441        set portname $PortInfo(name)
1442
1443        # Check to make sure the requested variations are available with this
1444        # port, if one is not, warn the user and remove the variant from the
1445        # array.
1446        foreach key [array names upvariations *] {
1447                if {![info exists PortInfo(variants)] ||
1448                        [lsearch $PortInfo(variants) $key] == -1} {
1449                        ui_debug "Requested variant $key is not provided by port $portname."
1450                        array unset upvariations $key
1451                }
1452        }
1453
1454    # now that we've selected variants, change all provides [a b c] to [a-b-c]
1455    # this will eliminate ambiguity between item a, b, and a-b while fulfilling requirments.
1456    #foreach obj $dlist {
1457    #    $obj set provides [list [join [$obj get provides] -]]
1458    #}
1459   
1460    set newlist [list]
1461    foreach variant $chosen {
1462                set newlist [dlist_append_dependents $dlist $variant $newlist]
1463    }
1464   
1465    set dlist [dlist_eval $newlist "" variant_run]
1466    if {[llength $dlist] > 0} {
1467                return 1
1468    }
1469
1470    # Now compute the true active array of variants. Note we do not
1471    # change upvariations any further, since that represents the
1472    # requested list of variations; but the registry for consistency
1473    # must encode the actual list of variants evaluated, however that
1474    # came to pass (dependencies, defaults, etc.) While we're at it,
1475    # it's convenient to check for inconsistent requests for
1476    # variations, namely foo +requirer -required where the 'requirer'
1477    # variant requires the 'required' one.
1478    array set activevariants [list]
1479    foreach dvar $newlist {
1480        set thevar [ditem_key $dvar provides]
1481        if {[info exists upvariations($thevar)] && $upvariations($thevar) eq "-"} {
1482            set chosenlist ""
1483            foreach choice $chosen {
1484                lappend chosenlist +[ditem_key $choice provides]
1485            }
1486            ui_error "Inconsistent variant specification: $portname variant +$thevar is required by at least one of $chosenlist, but specified -$thevar"
1487            return 1
1488        }
1489        set activevariants($thevar) "+"
1490    }
1491
1492    # Record a canonical variant string, used e.g. in accessing the registry
1493    set portvariants [canonicalize_variants [array get activevariants]]
1494
1495    # XXX: I suspect it would actually work better in the following
1496    # block to record the activevariants in the statefile rather than
1497    # the upvariations, since as far as I can see different sets of
1498    # upvariations which amount to the same activevariants in the end
1499    # can share all aspects of the build. But I'm leaving this alone
1500    # for the time being, so that someone with more extensive
1501    # experience can examine the idea before putting it into
1502    # action. -- GlenWhitney
1503
1504    return 0
1505}
1506
1507proc check_variants {variations target} {
1508    global ports_force PortInfo
1509    upvar $variations upvariations
1510    set result 0
1511    set portname $PortInfo(name)
1512   
1513    # Make sure the variations match those stored in the statefile.
1514    # If they don't match, print an error indicating a 'port clean'
1515    # should be performed. 
1516    # - Skip this test if the statefile is empty.
1517    # - Skip this test if performing a clean or submit.
1518    # - Skip this test if ports_force was specified.
1519   
1520    if { [lsearch "clean submit" $target] < 0 &&
1521                !([info exists ports_force] && $ports_force == "yes")} {
1522               
1523                set state_fd [open_statefile]
1524       
1525                if {[check_statefile_variants upvariations $state_fd]} {
1526                        ui_error "Requested variants do not match original selection.\nPlease perform 'port clean $portname' or specify the force option."
1527                        set result 1
1528                } else {
1529                        # Write variations out to the statefile
1530                        foreach key [array names upvariations *] {
1531                        write_statefile variant $upvariations($key)$key $state_fd
1532                        }
1533                }
1534               
1535                close $state_fd
1536    }
1537   
1538    return $result
1539}
1540
1541# Target class definition.
1542
1543# constructor for target object
1544proc target_new {name procedure} {
1545    global targets
1546    set ditem [ditem_create]
1547   
1548    ditem_key $ditem name $name
1549    ditem_key $ditem procedure $procedure
1550   
1551    lappend targets $ditem
1552   
1553    return $ditem
1554}
1555
1556proc target_provides {ditem args} {
1557    global targets
1558    # Register the pre-/post- hooks for use in Portfile.
1559    # Portfile syntax: pre-fetch { puts "hello world" }
1560    # User-code exceptions are caught and returned as a result of the target.
1561    # Thus if the user code breaks, dependent targets will not execute.
1562    foreach target $args {
1563        set origproc [ditem_key $ditem procedure]
1564        set ident [ditem_key $ditem name]
1565        if {[info commands $target] != ""} {
1566            ui_debug "$ident registered provides '$target', a pre-existing procedure. Target override will not be provided"
1567        } else {
1568            proc $target {args} "
1569                variable proc_index
1570                set proc_index \[llength \[ditem_key $ditem proc\]\]
1571                ditem_key $ditem procedure proc-${ident}-${target}-\${proc_index}
1572                proc proc-${ident}-${target}-\${proc_index} {name} \"
1573                    if {\\\[catch userproc-${ident}-${target}-\${proc_index} result\\\]} {
1574                        return -code error \\\$result
1575                    } else {
1576                        return 0
1577                    }
1578                \"
1579                proc do-$target {} { $origproc $target }
1580                makeuserproc userproc-${ident}-${target}-\${proc_index} \$args
1581            "
1582        }
1583        proc pre-$target {args} "
1584            variable proc_index
1585            set proc_index \[llength \[ditem_key $ditem pre\]\]
1586            ditem_append $ditem pre proc-pre-${ident}-${target}-\${proc_index}
1587            proc proc-pre-${ident}-${target}-\${proc_index} {name} \"
1588                if {\\\[catch userproc-pre-${ident}-${target}-\${proc_index} result\\\]} {
1589                    return -code error \\\$result
1590                } else {
1591                    return 0
1592                }
1593            \"
1594            makeuserproc userproc-pre-${ident}-${target}-\${proc_index} \$args
1595        "
1596        proc post-$target {args} "
1597            variable proc_index
1598            set proc_index \[llength \[ditem_key $ditem post\]\]
1599            ditem_append $ditem post proc-post-${ident}-${target}-\${proc_index}
1600            proc proc-post-${ident}-${target}-\${proc_index} {name} \"
1601                if {\\\[catch userproc-post-${ident}-${target}-\${proc_index} result\\\]} {
1602                    return -code error \\\$result
1603                } else {
1604                    return 0
1605                }
1606            \"
1607            makeuserproc userproc-post-${ident}-${target}-\${proc_index} \$args
1608        "
1609    }
1610    eval ditem_append $ditem provides $args
1611}
1612
1613proc target_requires {ditem args} {
1614    eval ditem_append $ditem requires $args
1615}
1616
1617proc target_uses {ditem args} {
1618    eval ditem_append $ditem uses $args
1619}
1620
1621proc target_deplist {ditem args} {
1622    eval ditem_append $ditem deplist $args
1623}
1624
1625proc target_prerun {ditem args} {
1626    eval ditem_append $ditem prerun $args
1627}
1628
1629proc target_postrun {ditem args} {
1630    eval ditem_append $ditem postrun $args
1631}
1632
1633proc target_runtype {ditem args} {
1634    eval ditem_append $ditem runtype $args
1635}
1636
1637proc target_state {ditem args} {
1638    eval ditem_append $ditem state $args
1639}
1640
1641proc target_init {ditem args} {
1642    eval ditem_append $ditem init $args
1643}
1644
1645##### variant class #####
1646
1647# constructor for variant objects
1648proc variant_new {name} {
1649    set ditem [ditem_create]
1650    ditem_key $ditem name $name
1651    return $ditem
1652}
1653
1654proc handle_default_variants {option action {value ""}} {
1655    global variations
1656    switch -regex $action {
1657        set|append {
1658            foreach v $value {
1659                if {[regexp {([-+])([-A-Za-z0-9_]+)} $v whole val variant]} {
1660                    if {![info exists variations($variant)]} {
1661                        set variations($variant) $val
1662                    }
1663                }
1664            }
1665        }
1666        delete {
1667            # xxx
1668        }
1669    }
1670}
1671
1672
1673# builds the specified port (looked up in the index) to the specified target
1674# doesn't yet support options or variants...
1675# newworkpath defines the port's workpath - useful for when one port relies
1676# on the source, etc, of another
1677proc portexec_int {portname target {newworkpath ""}} {
1678    ui_debug "Executing $target ($portname)"
1679    set variations [list]
1680    if {$newworkpath == ""} {
1681        array set options [list]
1682    } else {
1683        set options(workpath) ${newworkpath}
1684    }
1685    # Escape regex special characters
1686    regsub -all "(\\(){1}|(\\)){1}|(\\{1}){1}|(\\+){1}|(\\{1}){1}|(\\{){1}|(\\}){1}|(\\^){1}|(\\$){1}|(\\.){1}|(\\\\){1}" $portname "\\\\&" search_string
1687   
1688    set res [mport_search ^$search_string\$]
1689    if {[llength $res] < 2} {
1690        ui_error "Dependency $portname not found"
1691        return -1
1692    }
1693   
1694    array set portinfo [lindex $res 1]
1695    set porturl $portinfo(porturl)
1696    if {[catch {set worker [mport_open $porturl [array get options] $variations]} result]} {
1697                global errorInfo
1698                ui_debug "$errorInfo"
1699        ui_error "Opening $portname $target failed: $result"
1700        return -1
1701    }
1702    if {[catch {mport_exec $worker $target} result] || $result != 0} {
1703                global errorInfo
1704                ui_debug "$errorInfo"
1705        ui_error "Execution $portname $target failed: $result"
1706        mport_close $worker
1707        return -1
1708    }
1709    mport_close $worker
1710   
1711    return 0
1712}
1713
1714# portfile primitive that calls portexec_int with newworkpath == ${workpath}
1715proc portexec {portname target} {
1716    global workpath
1717    return [portexec_int $portname $target $workpath]
1718}
1719
1720proc adduser {name args} {
1721    global os.platform
1722    set passwd {*}
1723    set uid [nextuid]
1724    set gid [existsgroup nogroup]
1725    set realname ${name}
1726    set home /dev/null
1727    set shell /dev/null
1728   
1729    foreach arg $args {
1730        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
1731            regsub -all " " ${val} "\\ " val
1732            set $key $val
1733        }
1734    }
1735   
1736    if {[existsuser ${name}] != 0 || [existsuser ${uid}] != 0} {
1737        return
1738    }
1739   
1740    if {${os.platform} eq "darwin"} {
1741        exec dscl . -create /Users/${name} Password ${passwd}
1742        exec dscl . -create /Users/${name} UniqueID ${uid}
1743        exec dscl . -create /Users/${name} PrimaryGroupID ${gid}
1744        exec dscl . -create /Users/${name} RealName ${realname}
1745        exec dscl . -create /Users/${name} NFSHomeDirectory ${home}
1746        exec dscl . -create /Users/${name} UserShell ${shell}
1747    } else {
1748        # XXX adduser is only available for darwin, add more support here
1749        ui_warn "WARNING: adduser is not implemented on ${os.platform}."
1750        ui_warn "The requested user was not created."
1751    }
1752}
1753
1754proc addgroup {name args} {
1755    global os.platform
1756    set gid [nextgid]
1757    set realname ${name}
1758    set passwd {*}
1759    set users ""
1760   
1761    foreach arg $args {
1762        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
1763            regsub -all " " ${val} "\\ " val
1764            set $key $val
1765        }
1766    }
1767   
1768    if {[existsgroup ${name}] != 0 || [existsgroup ${gid}] != 0} {
1769        return
1770    }
1771   
1772    if {${os.platform} eq "darwin"} {
1773        exec dscl . -create /Groups/${name} Password ${passwd}
1774        exec dscl . -create /Groups/${name} RealName ${realname}
1775        exec dscl . -create /Groups/${name} PrimaryGroupID ${gid}
1776        if {${users} ne ""} {
1777            exec dscl . -create /Groups/${name} GroupMembership ${users}
1778        }
1779    } else {
1780        # XXX addgroup is only available for darwin, add more support here
1781        ui_warn "WARNING: addgroup is not implemented on ${os.platform}."
1782        ui_warn "The requested group was not created."
1783    }
1784}
1785
1786# proc to calculate size of a directory
1787# moved here from portpkg.tcl
1788proc dirSize {dir} {
1789    set size    0;
1790    foreach file [readdir $dir] {
1791        if {[file type [file join $dir $file]] == "link" } {
1792            continue
1793        }
1794        if {[file isdirectory [file join $dir $file]]} {
1795            incr size [dirSize [file join $dir $file]]
1796        } else {
1797            incr size [file size [file join $dir $file]];
1798        }
1799    }
1800    return $size;
1801}
1802
1803# check for a binary in the path
1804# returns an error code if it can not be found
1805proc binaryInPath {binary} {
1806    global env
1807    foreach dir [split $env(PATH) :] { 
1808        if {[file executable [file join $dir $binary]]} {
1809            return [file join $dir $binary]
1810        }
1811    }
1812   
1813    return -code error [format [msgcat::mc "Failed to locate '%s' in path: '%s'"] $binary $env(PATH)];
1814}
1815
1816# Set the UI prefix to something standard (so it can be grepped for in output)
1817proc set_ui_prefix {} {
1818        global UI_PREFIX env
1819        if {[info exists env(UI_PREFIX)]} {
1820                set UI_PREFIX $env(UI_PREFIX)
1821        } else {
1822                set UI_PREFIX "---> "
1823        }
1824}
1825
1826# Use a specified group/version.
1827proc PortGroup {group version} {
1828        global portresourcepath
1829
1830        set groupFile ${portresourcepath}/group/${group}-${version}.tcl
1831
1832        if {[file exists $groupFile]} {
1833                uplevel "source $groupFile"
1834        } else {
1835                ui_warn "Group file could not be located."
1836        }
1837}
1838
1839# check if archive type is supported by current system
1840# returns an error code if it is not
1841proc archiveTypeIsSupported {type} {
1842    global os.platform os.version
1843        set errmsg ""
1844        switch -regex $type {
1845                cp(io|gz) {
1846                        set pax "pax"
1847                        if {[catch {set pax [binaryInPath $pax]} errmsg] == 0} {
1848                                if {[regexp {z$} $type]} {
1849                                        set gzip "gzip"
1850                                        if {[catch {set gzip [binaryInPath $gzip]} errmsg] == 0} {
1851                                                return 0
1852                                        }
1853                                } else {
1854                                        return 0
1855                                }
1856                        }
1857                }
1858                t(ar|bz|gz) {
1859                        set tar "tar"
1860                        if {[catch {set tar [binaryInPath $tar]} errmsg] == 0} {
1861                                if {[regexp {z2?$} $type]} {
1862                                        if {[regexp {bz2?$} $type]} {
1863                                                set gzip "bzip2"
1864                                        } else {
1865                                                set gzip "gzip"
1866                                        }
1867                                        if {[catch {set gzip [binaryInPath $gzip]} errmsg] == 0} {
1868                                                return 0
1869                                        }
1870                                } else {
1871                                        return 0
1872                                }
1873                        }
1874                }
1875                xar {
1876                        set xar "xar"
1877                        if {[catch {set xar [binaryInPath $xar]} errmsg] == 0} {
1878                                return 0
1879                        }
1880                }
1881                zip {
1882                        set zip "zip"
1883                        if {[catch {set zip [binaryInPath $zip]} errmsg] == 0} {
1884                                set unzip "unzip"
1885                                if {[catch {set unzip [binaryInPath $unzip]} errmsg] == 0} {
1886                                        return 0
1887                                }
1888                        }
1889                }
1890                default {
1891                        return -code error [format [msgcat::mc "Invalid port archive type '%s' specified!"] $type]
1892                }
1893        }
1894        return -code error [format [msgcat::mc "Unsupported port archive type '%s': %s"] $type $errmsg]
1895}
1896
Note: See TracBrowser for help on using the repository browser.