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

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

Changes to allow arguments to command.{var} procedures to contain spaces within individual arguments

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