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

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

Use flock on .darwinports.state file instead of Portfile; gets the flock call out of darwinports.tcl API layer and makes Rob a happier, healthier person

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