source: trunk/base/src/macports1.0/macports_dlist.tcl @ 93962

Last change on this file since 93962 was 93962, checked in by jmr@…, 8 years ago

add debug message to dlist_eval

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