source: trunk/base/src/darwinports1.0/darwinports_dlist.tcl @ 2083

Last change on this file since 2083 was 2083, checked in by kevin, 18 years ago

Minor bugfixes.

  • Property svn:eol-style set to native
File size: 10.2 KB
Line 
1#!/usr/bin/env tclsh8.3
2# darwinports1.0/darwinports_dlist.tcl
3#
4# Copyright (c) 2003 Kevin Van Vechten <kevin@opendarwin.org>
5# Copyright (c) 2002 Apple Computer, Inc.
6# All rights reserved.
7#
8# Redistribution and use in source and binary forms, with or without
9# modification, are permitted provided that the following conditions
10# are met:
11# 1. Redistributions of source code must retain the above copyright
12#    notice, this list of conditions and the following disclaimer.
13# 2. Redistributions in binary form must reproduce the above copyright
14#    notice, this list of conditions and the following disclaimer in the
15#    documentation and/or other materials provided with the distribution.
16# 3. Neither the name of Apple Computer, Inc. nor the names of its contributors
17#    may be used to endorse or promote products derived from this software
18#    without specific prior written permission.
19#
20# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
21# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
22# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
23# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
24# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
25# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
26# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
27# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
28# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
29# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
30# POSSIBILITY OF SUCH DAMAGE.
31
32package provide darwinports_dlist 1.0
33
34# dependency dependency list evaluation package
35#
36# This package provides a generic mechanism for managing a list of
37# dependencies.  The basic model is that each dependency item
38# contains a list of tokens it Requires and tokens it Provides.
39# A dependency is selected once all of the tokens it Requires have
40# been provided by another dependency, or if a dependency has no
41# requirements.
42
43# Conceptually a dlist is an ordered list of ditem elements.
44# The order perserves the dependency hierarchy.
45
46# A dlist is an ordinary TCL list.
47# A ditem should be created with the [ditem_create] procedure,
48# and treated as an opaque reference.
49# A statusdict is an ordinary TCL array, though darwinports_dlist
50# should be given complete domain over its contents.
51# XXX: should statusdict and dlist be part of a ditem tuple?
52# Values in the status dict will be {-1, 0, 1} for {failure,
53# pending, success} respectively.
54
55# dlist_search
56# Returns all dependency entries whose 'key' contains 'value'.
57#       dlist - the dependency list to search
58#       key   - the key to compare: Requires, Provides, et al.
59#       value - the value to compare
60
61proc dlist_search {dlist key value} {
62        set result {}
63        foreach ditem $dlist {
64                if {[ditem_contains $ditem $key $value]} {
65                        lappend result $ditem
66                }
67        }
68        return $result
69}
70
71# dlist_has_pending
72# Returns true if the dlist contains ditems
73# which will provide one of the specified names,
74# and thus are still "pending".
75#       dlist  - the dependency list to search
76#       tokens - the list of pending tokens to check for
77
78proc dlist_has_pending {dlist tokens} {
79        foreach token $tokens {
80                if {[llength [dlist_search $dlist provides $token]] > 0} {
81                        return 1
82                }
83        }
84        return 0
85}
86
87# dlist_count_unmet
88# Returns the total number of unmet dependencies in
89# the list of tokens.  If the tokens are in the status
90# dictionary with a successful result code, they are
91# considered met.
92proc dlist_count_unmet {dlist statusdict tokens} {
93        upvar $statusdict upstatus
94        set result 0
95        foreach token $tokens {
96                if {[info exists upstatus($token)] &&
97                        $upstatus($token) == 1} {
98                        continue
99                } else {
100                        incr result
101                }
102        }
103        return $result
104}
105
106# ditem_create
107# Create a new array in the darwinports_dlist namespace
108# returns the name of the array.  This should be used as
109# the ditem handle.
110
111proc ditem_create {} {
112        return [darwinports_dlist::ditem_create]
113}
114
115# ditem_key
116# Sets and returns the given key of the dependency item.
117#       ditem - the dependency item to operate on
118#       key   - the key to set
119#       value - optional value to set the key to
120
121proc ditem_key {ditem args} {
122        if {[llength $args] > 1} {
123                return [darwinports_dlist::ditem_key $ditem [lindex $args 0] [lindex $args 1]]
124        } else {
125                return [darwinports_dlist::ditem_key $ditem [lindex $args 0]]
126        }
127}
128
129# ditem_append
130# Appends the value to the given key of the dependency item.
131#       ditem - the dependency item to operate on
132#       key   - the key to append to
133#       value - the value to append to the key
134
135proc ditem_append {ditem key args} {
136        eval "return \[darwinports_dlist::ditem_append $ditem $key $args\]"
137}
138
139# ditem_contains
140# Tests whether the ditem key contains the specified value;
141# or if the value is omitted, tests whether the key exists.
142#       ditem - the dependency item to test
143#       key   - the key to examine
144#       value - optional value to search for in the key
145proc ditem_contains {ditem key args} {
146        eval "return \[darwinports_dlist::ditem_contains $ditem $key $args\]"
147}
148
149# dlist_append_dependents
150# Returns the ditems which are dependents of the ditem specified.
151#       dlist - the dependency list to search
152#       ditem - the item which itself, and its dependents should be selected
153#       result - used for recursing, pass empty initially.
154
155proc dlist_append_dependents {dlist ditem result} {
156        # Append the root item to the list if it's not there.
157        if {[lsearch $result $ditem] == -1} {
158                lappend result $ditem
159        }
160        # Recursively append any hard dependencies.
161        foreach token [ditem_key $ditem requires] {
162                foreach provider [dlist_search $dlist provides $token] {
163                        set result [dlist_append_dependents $dlist $provider $result]
164                }
165        }
166        # XXX: add soft-dependencies?
167        return $result
168}
169
170# dlist_get_next
171# Returns the any eligible item from the dependency list.
172# Eligibility is a function of the ditems in the list and
173# the status dictionary.  A ditem is eligible when all of
174# the services it Requires are present in the status
175# dictionary with a successful result code.
176#
177# Notes: this implementation of get next defers items based
178# on unfulfilled tokens in the Uses key.  However these items
179# will eventually be returned if there are no alternatives.
180# Soft-dependencies can be implemented in this way.
181#       dlist      - the dependency list to select from
182#       statusdict - the status dictionary describing the history
183#                    of the dependency list.
184
185proc dlist_get_next {dlist statusdict} {
186        upvar $statusdict upstatus
187        set nextitem {}
188       
189        # arbitrary large number ~ INT_MAX
190        set minfailed 2000000000
191       
192        foreach ditem $dlist {
193                # Skip if the ditem has unsatisfied hard dependencies
194                if {[dlist_count_unmet $dlist upstatus [ditem_key $ditem requires]]} {
195                        continue
196                }
197               
198                # We will favor the ditem with the fewest unmet soft dependencies
199                set unmet [dlist_count_unmet $dlist upstatus [ditem_key $ditem uses]]
200               
201                # Delay items with unment soft dependencies that can eventually be met
202                if {$unmet > 0 && [dlist_has_pending $dlist [ditem_key $ditem uses]]} {
203                        continue
204                }
205               
206                if {$unmet >= $minfailed} {
207                        # not better than the last pick
208                        continue
209                } else {
210                        # better than the last pick (fewer unmet soft deps)
211                        set minfailed $unmet
212                        set nextitem $ditem
213                }
214        }
215        return $nextitem
216}
217
218# dlist_eval
219# Evaluate the dlist, select each eligible ditem according to
220# the optional selector argument (the default selector is
221# dlist_get_next).  The specified handler is then invoked on
222# each ditem in the order they are selected.  When no more
223# ditems are eligible to run (the selector returns {}) then
224# dlist_eval will exit with a list of the remaining ditems,
225# or {} if all ditems were evaluated.
226#       dlist    - the dependency list to evaluate
227#       handler  - the handler to invoke on each ditem
228#       selector - the selector for determining eligibility
229
230proc dlist_eval {dlist handler {selector "dlist_get_next"}} {
231        array set statusdict [list]
232       
233        # Do a pre-run seeing if any items automagically
234        # can evaluate to true.
235        foreach ditem $dlist {
236                #if test ditem
237                if {0} {
238                        foreach token [dlist_key $ditem provides] {
239                                set statusdict($name) 1
240                        }
241                        ldelete dlist $ditem
242                }
243        }
244       
245        # Loop for as long as there are ditems in the dlist.
246        while {1} {
247                set ditem [$selector $dlist statusdict]
248               
249                if {$ditem == {}} {
250                        break
251                } else {
252                        # $handler should return a unix status code, 0 for success.
253                        # statusdict notation is 1 for success
254                        if {[catch {$handler $ditem} result]} {
255                                puts $result
256                                return $dlist
257                        }
258                        # No news is good news at this point.
259                        if {$result == {}} { set result 0 }
260                       
261                        foreach token [ditem_key $ditem provides] {
262                                set statusdict($token) [expr $result == 0]
263                        }
264                       
265                        # Delete the ditem from the waiting list.
266                        darwinports_dlist::ldelete dlist $ditem
267                }
268        }
269       
270        # Return the list of lusers
271        return $dlist
272}
273
274
275##### Private API #####
276# Anything below this point is subject to change without notice.
277#####
278
279# Each ditem is actually an array in the darwinports_dlist
280# namespace.  ditem keys correspond to the equivalent array
281# key.  A dlist is simply a list of names of ditem arrays.
282# All private API functions exist in the darwinports_dlist
283# namespace.
284
285namespace eval darwinports_dlist {
286
287variable ditem_uniqid 0
288
289proc ditem_create {} {
290        variable ditem_uniqid
291        incr ditem_uniqid
292        set ditem "ditem_${ditem_uniqid}"
293        variable $ditem
294        array set $ditem [list]
295        return $ditem
296}
297
298proc ditem_key {ditem args} {
299        variable $ditem
300        set key [lindex $args 0]
301        if {[llength $args] > 1} {
302                array set $ditem [list $key [lindex $args 1]]
303        }
304        return [lindex [array get $ditem $key] 1]
305}
306
307proc ditem_append {ditem key args} {
308        variable $ditem
309        set x [lindex [array get $ditem $key] 1]
310        if {$x != {}} {
311                eval "lappend x $args"
312        } else {
313                set x $args
314        }
315        array set $ditem [list $key $x]
316        return $x
317}
318
319proc ditem_contains {ditem key args} {
320        variable $ditem
321        if {[llength $args] == 0} {
322                eval "return \[info exists ${ditem}($key)\]"
323        } else {
324                set x [lindex [array get $ditem $key] 1]
325                if {[llength $x] > 0 && [lsearch -exact $x [lindex $args 0]] != -1} {
326                        return 1
327                } else {
328                        return 0
329                }
330        }
331}
332
333proc ldelete {list value} {
334    upvar $list uplist
335    set ix [lsearch -exact $uplist $value]
336    if {$ix >= 0} {
337        set uplist [lreplace $uplist $ix $ix]
338    }
339}
340
341# End of darwinports_dlist namespace
342}
343
Note: See TracBrowser for help on using the repository browser.