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

Last change on this file since 618 was 618, checked in by landonf, 16 years ago

Run custom option procedure only once in ${option}-delete

  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 25.0 KB
Line 
1# ex:ts=4
2# portutil.tcl
3#
4# Copyright (c) 2002 Apple Computer, Inc.
5# All rights reserved.
6#
7# Redistribution and use in source and binary forms, with or without
8# modification, are permitted provided that the following conditions
9# are met:
10# 1. Redistributions of source code must retain the above copyright
11#    notice, this list of conditions and the following disclaimer.
12# 2. Redistributions in binary form must reproduce the above copyright
13#    notice, this list of conditions and the following disclaimer in the
14#    documentation and/or other materials provided with the distribution.
15# 3. Neither the name of Apple Computer, Inc. nor the names of its contributors
16#    may be used to endorse or promote products derived from this software
17#    without specific prior written permission.
18#
19# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
20# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
21# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
22# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
23# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
24# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
25# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
26# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
27# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
28# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
29# POSSIBILITY OF SUCH DAMAGE.
30#
31
32package provide portutil 1.0
33package require Pextlib 1.0
34
35global targets target_uniqid variants
36
37set target_uniqid 0
38
39########### External High Level Procedures ###########
40
41namespace eval options {
42}
43
44# options
45# Exports options in an array as externally callable procedures
46# Thus, "options name date" would create procedures named "name"
47# and "date" that set global variables "array" and "date", respectively
48# Arguments: <list of options>
49proc options {args} {
50    foreach option $args {
51        eval "proc $option {args} \{ \n\
52            global ${option} user_options \n\
53                \if \{!\[info exists user_options(${option})\]\} \{ \n\
54                     set ${option} \$args \n\
55                         if \{\[info commands options::${option}\] != \"\"\} \{ \n\
56                             options::${option} ${option} \n\
57                         \} \n\
58                \} \n\
59        \}"
60
61        eval "proc ${option}-delete {args} \{ \n\
62            global ${option} user_options \n\
63                \if \{!\[info exists user_options(${option})\]\} \{ \n\
64                    foreach val \$args \{ \n\
65                        ldelete ${option} \$val \n\
66                    \} \n\
67                    if \{\[info commands options::${option}\] != \"\"\} \{ \n\
68                        options::${option} ${option} \n\
69                    \} \n\
70                \} \n\
71        \}"
72        eval "proc ${option}-append {args} \{ \n\
73            global ${option} user_options \n\
74                \if \{!\[info exists user_options(${option})\]\} \{ \n\
75                    set $option \[concat \$$option \$args\] \n\
76                        if \{\[info commands options::${option}\] != \"\"\} \{ \n\
77                            options::${option} ${option} \n\
78                        \} \n\
79                \} \n\
80        \}"
81    }
82}
83
84proc options_export {args} {
85    foreach option $args {
86        eval "proc options::${option} {args} \{ \n\
87            global ${option} PortInfo \n\
88                set PortInfo(${option}) \$${option}\n\
89        \}"
90    }
91}
92
93proc commands {args} {
94    foreach option $args {
95        options use_${option} ${option}.dir ${option}.pre_args ${option}.args ${option}.post_args ${option}.env ${option}.type ${option}.cmd
96    }
97}
98
99proc command {command} {
100    global ${command}.dir ${command}.pre_args ${command}.args ${command}.post_args ${command}.env ${command}.type ${command}.cmd
101
102    set cmdstring ""
103    if [info exists ${command}.dir] {
104        set cmdstring "cd [set ${command}.dir] &&"
105    }
106
107    if [info exists ${command}.env] {
108        set cmdstring "$cmdstring [set ${command}.env]"
109    }
110
111    if [info exists ${command}.cmd] {
112        set cmdstring "$cmdstring [set ${command}.cmd]"
113    } else {
114        set cmdstring "$cmdstring ${command}"
115    }
116    foreach var "${command}.pre_args ${command}.args ${command}.post_args" {
117        if [info exists $var] {
118            set cmdstring "$cmdstring [set $var]"
119        }
120    }
121    return $cmdstring
122}
123
124# default
125proc default {option val} {
126    global $option option_defaults
127        if {[info exists option_defaults($option)]} {
128                ui_debug "Re-registering default for $option"
129        } else {
130                # If option is already set and we did not set it
131                # do not reset the value
132                if {[info exists $option]} {
133                        return
134                }
135        }
136        set option_defaults($option) $val
137        set $option $val
138        trace variable $option rwu default_check
139}
140
141proc default_check {optionName index op} {
142        global option_defaults $optionName
143        switch $op {
144                w {
145                        unset option_defaults($optionName)
146                        trace vdelete $optionName rwu default_check
147                        return
148                }
149                r {
150                        upvar $optionName option
151                        uplevel #0 set $optionName $option_defaults($optionName)
152                        return
153                }
154                u {
155                        unset option_defaults($optionName)
156                        trace vdelete $optionName rwu default_check
157                        return
158                }
159        }
160}
161
162# variant <provides> [<provides> ...] [requires <requires> [<requires>]]
163proc variant {args} {
164    global variants PortInfo
165    upvar $args upargs
166   
167    set len [llength $args]
168    set code [lindex $args end]
169    set args [lrange $args 0 [expr $len - 2]]
170   
171    set provides [list]
172    set requires [list]
173   
174    # halfway through the list we'll hit 'requires' which tells us
175    # to switch into processing required flavors/depspecs.
176    set after_requires 0
177    foreach arg $args {
178        if ([string equal $arg requires]) { 
179            set after_requires 1
180            continue
181        }
182        if ($after_requires) {
183            lappend requires $arg
184        } else {
185            lappend provides $arg
186        }
187    }
188    set name "variant-[join $provides -]"
189    dlist_add_item variants $name
190    dlist_append_key variants $name provides $provides
191    dlist_append_key variants $name requires $requires
192    dlist_set_key variants $name procedure $code
193    # Export provided variant to PortInfo
194    lappend PortInfo(variants) $provides
195}
196
197########### Misc Utility Functions ###########
198
199proc tbool {key} {
200    upvar $key $key
201    if {[info exists $key]} {
202        if {[string equal -nocase [set $key] "yes"]} {
203            return 1
204        }
205    }
206    return 0
207}
208
209proc ldelete {list value} {
210    upvar $list uplist
211    set ix [lsearch -exact $uplist $value]
212    if {$ix >= 0} {
213        set uplist [lreplace $uplist $ix $ix]
214    }
215}
216
217proc reinplace {oddpattern file}  {
218    set backpattern [strsed $oddpattern {g/\//\\\\\//}]
219    set pattern [strsed $backpattern {g/\|/\//}]
220
221    if {[catch {set input [open "$file" RDWR]} error]} {
222        ui_error "reinplace: $error"
223        return -code error "reinplace failed"
224    }
225
226    if {[catch {set result [mkstemp "/tmp/[file tail $file].sed.XXXXXXXX"]} error]} {
227        ui_error "reinplace: $error"
228        close $input
229        return -code error "reinplace failed"
230    }
231
232    set output [lindex $result 0]
233    set tmpfile [lindex $result 1]
234
235    if {[catch {exec sed $pattern <@$input >@$output} error]} {
236        ui_error "reinplace: $error"
237        close $output
238        close $input
239        file delete "$tmpfile"
240        return -code error "reinplace failed"
241    }
242
243    seek $output 0
244    seek $input 0
245
246    if {[catch {exec cat <@$output >@$input 2>/dev/null} error]} {
247        ui_error "reinplace: $error"
248        close $output
249        close $input
250        file delete "$tmpfile"
251        return -code error "reinplace failed"
252    }
253
254    close $output
255    close $input
256    file delete "$tmpfile"
257    return
258}
259
260proc filefindbypath {fname} {
261    global distpath filedir workdir worksrcdir portpath
262
263    if [file readable $fname] {
264        return $fname
265    } elseif [file readable $portpath/$fname] {
266        return $portpath/$fname
267    } elseif [file readable $portpath/$filedir/$fname] {
268        return $portpath/$filedir/$fname
269    } elseif [file readable $distpath/$fname] {
270        return $distpath/$fname
271    } elseif [file readable $portpath/$workdir/$worksrcdir/$fname] {
272        return $portpath/$workdir/$worksrcdir/$fname
273    } elseif [file readable [file join /etc $fname]] {
274        return [file join /etc $fname]
275    }
276    return ""
277}
278
279# Source a file, looking for it along a standard search path.
280proc include {fname} {
281    set tgt [filefindbypath $fname]
282    if [string length $tgt] {
283        uplevel "source $tgt"
284    } else {
285        return -code error "Unable to find include file $fname"
286    }
287}
288
289# makeuserproc
290# This procedure re-writes the user-defined custom target to include
291# all the globals in its scope.  This is undeniably ugly, but I haven't
292# thought of any other way to do this.
293proc makeuserproc {name body} {
294    regsub -- "^\{(.*)" $body "\{ \n foreach g \[info globals\] \{ \n global \$g \n \} \n \\1 " body
295    eval "proc $name {} $body"
296}
297
298########### External Dependancy Manipulation Procedures ###########
299# register
300# Creates a target in the global target list using the internal dependancy
301#     functions
302# Arguments: <identifier> <mode> <args ...>
303# The following modes are supported:
304#       <identifier> target <procedure to execute> [run type]
305#       <identifier> init <procedure to execute>
306#       <identifier> prerun <procedure to execute>
307#       <identifier> postrun <procedure to execute>
308#       <identifier> provides <list of target names>
309#       <identifier> requires <list of target names>
310#       <identifier> uses <list of target names>
311#       <provides> preflight <proc name>
312#       <provides> postflight <proc name>
313proc register {name mode args} {
314    global targets target_uniqid
315    dlist_add_item targets $name
316
317    if {[string equal target $mode]} {
318        set procedure [lindex $args 0]
319        if {[dlist_has_key targets $name procedure]} {
320            ui_debug "Warning: target '$name' re-registered (new procedure: '$procedure')"
321        }
322        dlist_set_key targets $name procedure $procedure
323               
324        # Set runtype {always,once} if available
325        if {[llength $args] >= 2} {
326            dlist_set_key targets $name runtype [lindex $args 1]
327        }
328    } elseif {[string equal init $mode]} {
329        set init [lindex $args 0]
330        if {[dlist_has_key targets $name init]} {
331           ui_debug "Warning: target '$name' re-registered init procedure (new procedure: '$init')"
332        }
333        dlist_set_key targets $name init $init
334    } elseif {[string equal prerun $mode]} {
335        set prerun [lindex $args 0]
336        if {[dlist_has_key targets $name prerun]} {
337           ui_debug "Warning: target '$name' re-registered pre-run procedure (new procedure: '$prerun')"
338        }
339        dlist_set_key targets $name prerun $prerun
340    } elseif {[string equal postrun $mode]} {
341        set postrun [lindex $args 0]
342        if {[dlist_has_key targets $name postrun]} {
343           ui_debug "Warning: target '$name' re-registered post-run procedure (new procedure: '$postrun')"
344        }
345        dlist_set_key targets $name postrun $postrun
346    } elseif {[string equal requires $mode] || [string equal uses $mode] || [string equal provides $mode]} {
347        if {[dlist_has_item targets $name]} {
348            dlist_append_key targets $name $mode $args
349        } else {
350            ui_info "Warning: target '$name' not-registered in register $mode"
351        }
352       
353        if {[string equal provides $mode]} {
354            # If it's a provides, register the pre-/post- hooks for use in Portfile.
355            # Portfile syntax: pre-fetch { puts "hello world" }
356            # User-code exceptions are caught and returned as a result of the target.
357            # Thus if the user code breaks, dependent targets will not execute.
358            foreach target $args {
359                if {[info commands $target] != ""} {
360                    ui_error "$name attempted to register provide \'$target\' which is a pre-existing procedure. Ignoring register."
361                    continue;
362                }
363                set ident [lindex [dlist_get_matches targets provides $args] 0]
364                set origproc [dlist_get_key targets $ident procedure]
365                eval "proc $target {args} \{ \n\
366                                        global target_uniqid \n\
367                                        set id \[incr target_uniqid\] \n\
368                    register $ident target proc-$target\$id \n\
369                    eval \"proc proc-$target\$id \{name\} \{ \n\
370                        if \\\[catch userproc-$target\$id result\\\] \{ \n\
371                                                        ui_info \\\$result \n\
372                                                        return 1 \n\
373                                                \} else \{ \n\
374                                                        return 0 \n\
375                                                \} \n\
376                    \}\" \n\
377                    eval \"proc do-$target \{\} \{ $origproc $target\}\" \n\
378                    makeuserproc userproc-$target\$id \$args \}"
379                eval "proc pre-$target {args} \{ \n\
380                                        global target_uniqid \n\
381                                        set id \[incr target_uniqid\] \n\
382                    register $target preflight pre-$target\$id \n\
383                    eval \"proc pre-$target\$id \{name\} \{ \n\
384                        if \\\[catch userproc-pre-$target\$id result\\\] \{ \n\
385                                                        ui_info \\\$result \n\
386                                                        return 1 \n\
387                                                \} else \{ \n\
388                                                        return 0 \n\
389                                                \} \n\
390                    \}\" \n\
391                    makeuserproc userproc-pre-$target\$id \$args \}"
392                eval "proc post-$target {args} \{ \n\
393                                        global target_uniqid \n\
394                                        set id \[incr target_uniqid\] \n\
395                    register $target postflight post-$target\$id \n\
396                    eval \"proc post-$target\$id \{name\} \{ \n\
397                        if \\\[catch userproc-post-$target\$id result\\\] \{ \n\
398                                                        ui_info \\\$result \n\
399                                                        return 1 \n\
400                                                \} else \{ \n\
401                                                        return 0 \n\
402                                                \} \n\
403                    \}\" \n\
404                    makeuserproc userproc-post-$target\$id \$args \}"
405            }
406        }
407       
408    } elseif {[string equal preflight $mode]} {
409                # Find target which provides the specified name, and add a preflight.
410                # XXX: this only returns the first match, is this what we want?
411                set ident [lindex [dlist_get_matches targets provides $name] 0]
412                dlist_append_key targets $ident pre $args
413               
414    } elseif {[string equal postflight $mode]} {
415                # Find target which provides the specified name, and add a preflight.
416                # XXX: this only returns the first match, is this what we want?
417                set ident [lindex [dlist_get_matches targets provides $name] 0]
418                dlist_append_key targets $ident post $args
419        }
420}
421
422
423# unregister
424# Unregisters a target in the global target list
425# Arguments: target <target name>
426proc unregister {mode target} {
427}
428
429########### Internal Dependancy Manipulation Procedures ###########
430
431# Dependency List (dlist)
432# The dependency list is really just one big array.  (I would have
433# liked to make this nested arrays, but that's not feasible in Tcl,
434# thus we'll use the $fieldname,$groupname syntax to mimic structures.
435#
436# Dependency lists may contain private data, via the
437# dlist_*_key APIs.  However, it must be recognized that the
438# following keys are reserved for use by the evaluation engine.
439# (Don't fret, you want these keys anyway, honest.)  These keys also
440# have predefined accessor APIs to remind you of their significance.
441#
442# Reserved keys:
443# name          - The unique identifier of the item.  No Commas!
444# provides      - The list of tokens this item provides
445# requires      - The list of hard-dependency tokens
446# uses          - The list of soft-dependency tokens
447# runtype       - The runtype of the item {always,once}
448
449# Sets the key/value to an item in the dependency list
450proc dlist_set_key {dlist name key args} {
451    upvar $dlist uplist
452    # might be keen to validate $name here.
453    eval "set uplist($key,$name) $args"
454}
455
456# Appends the value to the list stored at the key of the item
457proc dlist_append_key {dlist name key args} {
458    upvar $dlist uplist
459    if {![dlist_has_key uplist $name $key]} { set uplist($key,$name) [list] }
460    eval "lappend uplist($key,$name) [join $args]"
461}
462
463# Return true if the key exists for the item, false otherwise
464proc dlist_has_key {dlist name key} {
465    upvar $dlist uplist
466    return [info exists uplist($key,$name)]
467}
468
469# Retrieves the value of the key of an item in the dependency list
470proc dlist_get_key {dlist name key} {
471    upvar $dlist uplist
472    if {[info exists uplist($key,$name)]} {
473        return $uplist($key,$name)
474    } else {
475        return ""
476    }
477}
478
479# Adds a colorless odorless item to the dependency list
480proc dlist_add_item {dlist name} {
481    upvar $dlist uplist
482    set uplist(name,$name) $name
483}
484
485# Deletes all keys of the specified item
486proc dlist_remove_item {dlist name} {
487    upvar $dlist uplist
488    array unset uplist *,$name
489}
490
491# Tests if the item is present in the dependency list
492proc dlist_has_item {dlist name} {
493    upvar $dlist uplist
494    return [info exists uplist(name,$name)]
495}
496
497# Return a list of names of items that provide the given name
498proc dlist_get_matches {dlist key value} {
499    upvar $dlist uplist
500    set result [list]
501    foreach ident [array names uplist name,*] {
502        set name $uplist($ident)
503        foreach val [dlist_get_key uplist $name $key] {
504            if {[string equal $val $value] && 
505                ![info exists ${result}($name)]} {
506                lappend result $name
507            }
508        }
509    }
510    return $result
511}
512
513# Count the unmet dependencies in the dlist based on the statusdict
514proc dlist_count_unmet {names statusdict} {
515    upvar $statusdict upstatusdict
516    set unmet 0
517    foreach name $names {
518        if {![info exists upstatusdict($name)] ||
519            ![string equal $upstatusdict($name) success]} {
520            incr unmet
521        }
522    }
523    return $unmet
524}
525
526# Returns true if any of the dependencies are pending in the dlist
527proc dlist_has_pending {dlist uses} {
528    foreach name $uses {
529        if {[info exists ${dlist}(name,$name)]} { 
530            return 1
531        }
532    }
533    return 0
534}
535
536# Get the name of the next eligible item from the dependency list
537proc dlist_get_next {dlist statusdict} {
538    set nextitem ""
539    # arbitrary large number ~ INT_MAX
540    set minfailed 2000000000
541    upvar $dlist uplist
542    upvar $statusdict upstatusdict
543   
544    foreach n [array names uplist name,*] {
545        set name $uplist($n)
546       
547        # skip if unsatisfied hard dependencies
548        if {[dlist_count_unmet [dlist_get_key uplist $name requires] upstatusdict]} { continue }
549       
550        # favor item with fewest unment soft dependencies
551        set unmet [dlist_count_unmet [dlist_get_key uplist $name uses] upstatusdict]
552       
553        # delay items with unmet soft dependencies that can be filled
554        if {$unmet > 0 && [dlist_has_pending dlist [dlist_get_key uplist $name uses]]} { continue }
555       
556        if {$unmet >= $minfailed} {
557            # not better than our last pick
558            continue
559        } else {
560            # better than our last pick
561            set minfailed $unmet
562            set nextitem $name
563        }
564    }
565    return $nextitem
566}
567
568
569# Evaluate the dlist, invoking action on each name in the dlist as it
570# becomes eligible.
571proc dlist_evaluate {dlist downstatusdict action} {
572    # dlist - nodes waiting to be executed
573    upvar $dlist uplist
574    upvar $downstatusdict statusdict
575   
576    # status - keys will be node names, values will be success or failure.
577    array set statusdict [list]
578   
579    # loop for as long as there are nodes in the dlist.
580    while (1) {
581        set name [dlist_get_next uplist statusdict]
582        if {[string length $name] == 0} { 
583            break
584        } else {
585            set result [eval $action uplist $name]
586            foreach token $uplist(provides,$name) {
587                array set statusdict [list $token $result]
588            }
589            dlist_remove_item uplist $name
590        }
591    }
592   
593    set names [array names uplist name,*]
594        if { [llength $names] > 0} {
595                # somebody broke!
596                ui_info "Warning: the following items did not execute: "
597                foreach name $names {
598                        ui_info "$uplist($name) " -nonewline
599                }
600                ui_info ""
601                return 1
602    }
603        return 0
604}
605
606proc exec_target {fd dlist name} {
607# XXX: Don't depend on entire dlist, this should really receive just one node.
608    upvar $dlist uplist
609
610    if {[dlist_has_key uplist $name procedure]} {
611                set procedure [dlist_get_key uplist $name procedure]
612                if {[dlist_has_key uplist $name init]} {
613                        [dlist_get_key uplist $name init] $name
614                }
615                               
616                if {[check_statefile $name $fd]} {
617                        set result 0
618                        ui_debug "Skipping completed $name"
619                } else {
620                        # Execute pre-run procedure
621                        if {[dlist_has_key uplist $name prerun]} {
622                                [dlist_get_key uplist $name prerun] $name
623                        }
624
625                        foreach pre [dlist_get_key uplist $name pre] {
626                                ui_debug "Executing $pre"
627                                if {[$pre $name] != 0} { return failure }
628                        }
629
630                        ui_debug "Executing $name"
631                        set result [$procedure $name]
632
633                        foreach post [dlist_get_key uplist $name post] {
634                                ui_debug "Executing $post"
635                                if {[$post $name] != 0} { 
636                                        set result 1 
637                                        break
638                                }
639                        }
640                        # Execute post-run procedure
641                        if {[dlist_has_key uplist $name postrun]} {
642                                [dlist_get_key uplist $name postrun] $name
643                        }
644                }
645                if {$result == 0} {
646                        set result success
647                        if {[dlist_get_key uplist $name runtype] != "always"} {
648                        write_statefile $name $fd
649                        }
650                } else {
651                        ui_error "Target error: $name returned $result"
652                        set result failure
653                }
654               
655    } else {
656                ui_info "Warning: $name does not have a registered procedure"
657                set result failure
658    }
659       
660    return $result
661}
662
663proc eval_targets {dlist target} {
664    upvar $dlist uplist
665
666    # Select the subset of targets under $target
667    if {[string length $target] > 0} {
668                # XXX munge target. install really means registry, then install
669                # If more than one target ever needs this, make this a generic interface
670                if {[string equal $target "install"]} {
671                        set target registry
672                }
673        set matches [dlist_get_matches uplist provides $target]
674        if {[llength $matches] > 0} {
675            array set dependents [list]
676            dlist_append_dependents dependents uplist [lindex $matches 0]
677            array unset uplist
678            array set uplist [array get dependents]
679            # Special-case 'all'
680        } elseif {![string equal $target all]} {
681            ui_info "Warning: unknown target: $target"
682            return
683        }
684    }
685   
686    array set statusdict [list]
687   
688    # Restore the state from a previous run.
689    set fd [open_statefile]
690   
691    set ret [dlist_evaluate uplist statusdict [list exec_target $fd]]
692
693    close $fd
694        return $ret
695}
696
697# select dependents of <name> from the <itemlist>
698# adding them to <dependents>
699proc dlist_append_dependents {dependents dlist name} {
700    upvar $dependents updependents
701    upvar $dlist uplist
702
703    # Append item to the list, avoiding duplicates
704    if {![info exists updependents(name,$name)]} {
705        set names [array names uplist *,$name]
706        foreach n $names {
707            set updependents($n) $uplist($n)
708        }
709    }
710   
711    # Recursively append any hard dependencies
712    if {[info exists uplist(requires,$name)]} {
713        foreach dep $uplist(requires,$name) {
714            foreach provide [dlist_get_matches uplist provides $dep] {
715                dlist_append_dependents updependents uplist $provide
716            }
717        }
718    }
719   
720    # XXX: add soft-dependencies?
721}
722
723# open_statefile
724# open file to store name of completed targets
725proc open_statefile {args} {
726    global portpath workdir
727
728    if ![file isdirectory $portpath/$workdir] {
729        file mkdir $portpath/$workdir
730    }
731    set fd [open "$portpath/$workdir/.darwinports.state" a+]
732    return $fd
733}
734
735# check_statefile
736# Check completed state of target $name
737proc check_statefile {name fd} {
738    global portpath workdir
739
740    seek $fd 0
741    while {[gets $fd line] >= 0} {
742        if {[string equal $line $name]} {
743            return 1
744        }
745    }
746    return 0
747}
748
749# write_statefile
750# Set target $name completed in the state file
751proc write_statefile {name fd} {
752    if {[check_statefile $name $fd]} {
753        return 0
754    }
755    seek $fd 0 end
756    puts $fd $name
757    flush $fd
758}
759
760# Traverse the ports collection hierarchy and call procedure func for
761# each directory containing a Portfile
762proc port_traverse {func {dir .}} {
763    set pwd [pwd]
764    if [catch {cd $dir} err] {
765        ui_error $err
766        return
767    }
768    foreach name [readdir .] {
769        if {[string match $name .] || [string match $name ..]} {
770            continue
771        }
772        if [file isdirectory $name] {
773            port_traverse $func $name
774        } else {
775            if [string match $name Portfile] {
776                catch {eval $func {[file join $pwd $dir]}}
777            }
778        }
779    }
780    cd $pwd
781}
782
783
784########### Port Variants ###########
785
786# Each variant which provides a subset of the requested variations
787# will be chosen.  Returns a list of the selected variants.
788proc choose_variants {variants variations} {
789    upvar $variants upvariants
790    upvar $variations upvariations
791
792    set selected [list]
793   
794    foreach n [array names upvariants name,*] {
795                set name $upvariants($n)
796               
797                # Enumerate through the provides, tallying the pros and cons.
798                set pros 0
799                set cons 0
800                set ignored 0
801                foreach flavor [dlist_get_key upvariants $name provides] {
802                        if {[info exists upvariations($flavor)]} {
803                                if {$upvariations($flavor) == "+"} {
804                                        incr pros
805                                } elseif {$upvariations($flavor) == "-"} {
806                                        incr cons
807                                }
808                        } else {
809                                incr ignored
810                        }
811                }
812               
813                if {$cons > 0} { continue }
814               
815                if {$pros > 0 && $ignored == 0} {
816                        lappend selected $name
817                }
818        }
819    return $selected
820}
821
822proc exec_variant {dlist name} {
823# XXX: Don't depend on entire dlist, this should really receive just one node.
824    upvar $dlist uplist
825    ui_debug "Executing $name"
826    makeuserproc $name-code "\{[dlist_get_key uplist $name procedure]\}"
827    $name-code
828    return success
829}
830
831proc eval_variants {dlist variations} {
832    upvar $dlist uplist
833        upvar $variations upvariations
834
835        set chosen [choose_variants uplist upvariations]
836
837    # now that we've selected variants, change all provides [a b c] to [a-b-c]
838    # this will eliminate ambiguity between item a, b, and a-b while fulfilling requirments.
839    foreach n [array names uplist provides,*] {
840        array set uplist [list $n [join $uplist($n) -]]
841    }
842       
843        array set dependents [list]
844    foreach variant $chosen {
845        dlist_append_dependents dependents uplist $variant
846    }
847        array unset uplist
848        array set uplist [array get dependents]
849   
850    array set statusdict [list]
851       
852    dlist_evaluate uplist statusdict [list exec_variant]
853}
854
Note: See TracBrowser for help on using the repository browser.