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

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

Add more comments

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