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

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

Return error number on unknown target

  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 27.0 KB
Line 
1# ex:ts=4
2# portutil.tcl
3#
4# Copyright (c) 2002 Apple Computer, Inc.
5# All rights reserved.
6#
7# Redistribution and use in source and binary forms, with or without
8# modification, are permitted provided that the following conditions
9# are met:
10# 1. Redistributions of source code must retain the above copyright
11#    notice, this list of conditions and the following disclaimer.
12# 2. Redistributions in binary form must reproduce the above copyright
13#    notice, this list of conditions and the following disclaimer in the
14#    documentation and/or other materials provided with the distribution.
15# 3. Neither the name of Apple Computer, Inc. nor the names of its contributors
16#    may be used to endorse or promote products derived from this software
17#    without specific prior written permission.
18#
19# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
20# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
21# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
22# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
23# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
24# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
25# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
26# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
27# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
28# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
29# POSSIBILITY OF SUCH DAMAGE.
30#
31
32package provide portutil 1.0
33package require Pextlib 1.0
34
35global targets target_uniqid variants
36
37set target_uniqid 0
38
39########### External High Level Procedures ###########
40
41namespace eval options {
42}
43
44# options
45# Exports options in an array as externally callable procedures
46# Thus, "options name date" would create procedures named "name"
47# and "date" that set global variables "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# variant_isset name
220# Returns 1 if variant name selected, otherwise 0
221proc variant_isset {name} {
222    global variations
223
224    if {[info exists variations($name)] && $variations($name) == "+"} {
225        return 1
226    }
227    return 0
228}
229
230# variant_set name
231# Sets variant to run for current portfile
232proc variant_set {name} {
233    global variations
234
235    set variations($name) +
236}
237
238# variant_unset name
239# Clear variant for current portfile
240proc variant_unset {name} {
241    global variations
242
243    set variations($name) -
244}
245
246########### Misc Utility Functions ###########
247
248# tbool (testbool)
249# If the variable exists in the calling procedure's namespace
250# and is set to "yes", return 1. Otherwise, return 0
251proc tbool {key} {
252    upvar $key $key
253    if {[info exists $key]} {
254        if {[string equal -nocase [set $key] "yes"]} {
255            return 1
256        }
257    }
258    return 0
259}
260
261# ldelete
262# Deletes a value from the supplied list
263proc ldelete {list value} {
264    upvar $list uplist
265    set ix [lsearch -exact $uplist $value]
266    if {$ix >= 0} {
267        set uplist [lreplace $uplist $ix $ix]
268    }
269}
270
271# reinplace
272# Provides "sed in place" functionality
273proc reinplace {oddpattern file}  {
274    set backpattern [strsed $oddpattern {g/\//\\\\\//}]
275    set pattern [strsed $backpattern {g/\|/\//}]
276
277    if {[catch {set input [open "$file" RDWR]} error]} {
278        ui_error "reinplace: $error"
279        return -code error "reinplace failed"
280    }
281
282    if {[catch {set result [mkstemp "/tmp/[file tail $file].sed.XXXXXXXX"]} error]} {
283        ui_error "reinplace: $error"
284        close $input
285        return -code error "reinplace failed"
286    }
287
288    set output [lindex $result 0]
289    set tmpfile [lindex $result 1]
290
291    if {[catch {exec sed $pattern <@$input >@$output} error]} {
292        ui_error "reinplace: $error"
293        close $output
294        close $input
295        file delete "$tmpfile"
296        return -code error "reinplace failed"
297    }
298
299    seek $output 0
300    seek $input 0
301
302    if {[catch {exec cat <@$output >@$input 2>/dev/null} error]} {
303        ui_error "reinplace: $error"
304        close $output
305        close $input
306        file delete "$tmpfile"
307        return -code error "reinplace failed"
308    }
309
310    close $output
311    close $input
312    file delete "$tmpfile"
313    return
314}
315
316# filefindbypath
317# Provides searching of the standard path for included files
318proc filefindbypath {fname} {
319    global distpath filedir workdir worksrcdir portpath
320
321    if [file readable $fname] {
322        return $fname
323    } elseif [file readable $portpath/$fname] {
324        return $portpath/$fname
325    } elseif [file readable $portpath/$filedir/$fname] {
326        return $portpath/$filedir/$fname
327    } elseif [file readable $distpath/$fname] {
328        return $distpath/$fname
329    } elseif [file readable $portpath/$workdir/$worksrcdir/$fname] {
330        return $portpath/$workdir/$worksrcdir/$fname
331    } elseif [file readable [file join /etc $fname]] {
332        return [file join /etc $fname]
333    }
334    return ""
335}
336
337# include
338# Source a file, looking for it along a standard search path.
339proc include {fname} {
340    set tgt [filefindbypath $fname]
341    if [string length $tgt] {
342        uplevel "source $tgt"
343    } else {
344        return -code error "Unable to find include file $fname"
345    }
346}
347
348# makeuserproc
349# This procedure re-writes the user-defined custom target to include
350# all the globals in its scope.  This is undeniably ugly, but I haven't
351# thought of any other way to do this.
352proc makeuserproc {name body} {
353    regsub -- "^\{(.*)" $body "\{ \n foreach g \[info globals\] \{ \n global \$g \n \} \n \\1 " body
354    eval "proc $name {} $body"
355}
356
357########### External Dependancy Manipulation Procedures ###########
358# register
359# Creates a target in the global target list using the internal dependancy
360#     functions
361# Arguments: <identifier> <mode> <args ...>
362# The following modes are supported:
363#       <identifier> target <procedure to execute> [run type]
364#       <identifier> init <procedure to execute>
365#       <identifier> prerun <procedure to execute>
366#       <identifier> postrun <procedure to execute>
367#       <identifier> provides <list of target names>
368#       <identifier> requires <list of target names>
369#       <identifier> uses <list of target names>
370#       <provides> preflight <proc name>
371#       <provides> postflight <proc name>
372proc register {name mode args} {
373    global targets target_uniqid
374    dlist_add_item targets $name
375
376    if {[string equal target $mode]} {
377        set procedure [lindex $args 0]
378        if {[dlist_has_key targets $name procedure]} {
379            ui_debug "Warning: target '$name' re-registered (new procedure: '$procedure')"
380        }
381        dlist_set_key targets $name procedure $procedure
382               
383        # Set runtype {always,once} if available
384        if {[llength $args] >= 2} {
385            dlist_set_key targets $name runtype [lindex $args 1]
386        }
387    } elseif {[string equal init $mode]} {
388        set init [lindex $args 0]
389        if {[dlist_has_key targets $name init]} {
390           ui_debug "Warning: target '$name' re-registered init procedure (new procedure: '$init')"
391        }
392        dlist_set_key targets $name init $init
393    } elseif {[string equal prerun $mode]} {
394        set prerun [lindex $args 0]
395        if {[dlist_has_key targets $name prerun]} {
396           ui_debug "Warning: target '$name' re-registered pre-run procedure (new procedure: '$prerun')"
397        }
398        dlist_set_key targets $name prerun $prerun
399    } elseif {[string equal postrun $mode]} {
400        set postrun [lindex $args 0]
401        if {[dlist_has_key targets $name postrun]} {
402           ui_debug "Warning: target '$name' re-registered post-run procedure (new procedure: '$postrun')"
403        }
404        dlist_set_key targets $name postrun $postrun
405    } elseif {[string equal requires $mode] || [string equal uses $mode] || [string equal provides $mode]} {
406        if {[dlist_has_item targets $name]} {
407            dlist_append_key targets $name $mode $args
408        } else {
409            ui_info "Warning: target '$name' not-registered in register $mode"
410        }
411       
412        if {[string equal provides $mode]} {
413            # If it's a provides, register the pre-/post- hooks for use in Portfile.
414            # Portfile syntax: pre-fetch { puts "hello world" }
415            # User-code exceptions are caught and returned as a result of the target.
416            # Thus if the user code breaks, dependent targets will not execute.
417            foreach target $args {
418                if {[info commands $target] != ""} {
419                    ui_error "$name attempted to register provide \'$target\' which is a pre-existing procedure. Ignoring register."
420                    continue;
421                }
422                set ident [lindex [dlist_get_matches targets provides $args] 0]
423                set origproc [dlist_get_key targets $ident procedure]
424                eval "proc $target {args} \{ \n\
425                                        global target_uniqid \n\
426                                        set id \[incr target_uniqid\] \n\
427                    register $ident target proc-$target\$id \n\
428                    eval \"proc proc-$target\$id \{name\} \{ \n\
429                        if \\\[catch userproc-$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                    eval \"proc do-$target \{\} \{ $origproc $target\}\" \n\
437                    makeuserproc userproc-$target\$id \$args \}"
438                eval "proc pre-$target {args} \{ \n\
439                                        global target_uniqid \n\
440                                        set id \[incr target_uniqid\] \n\
441                    register $target preflight pre-$target\$id \n\
442                    eval \"proc pre-$target\$id \{name\} \{ \n\
443                        if \\\[catch userproc-pre-$target\$id result\\\] \{ \n\
444                                                        ui_info \\\$result \n\
445                                                        return 1 \n\
446                                                \} else \{ \n\
447                                                        return 0 \n\
448                                                \} \n\
449                    \}\" \n\
450                    makeuserproc userproc-pre-$target\$id \$args \}"
451                eval "proc post-$target {args} \{ \n\
452                                        global target_uniqid \n\
453                                        set id \[incr target_uniqid\] \n\
454                    register $target postflight post-$target\$id \n\
455                    eval \"proc post-$target\$id \{name\} \{ \n\
456                        if \\\[catch userproc-post-$target\$id result\\\] \{ \n\
457                                                        ui_info \\\$result \n\
458                                                        return 1 \n\
459                                                \} else \{ \n\
460                                                        return 0 \n\
461                                                \} \n\
462                    \}\" \n\
463                    makeuserproc userproc-post-$target\$id \$args \}"
464            }
465        }
466       
467    } elseif {[string equal preflight $mode]} {
468                # Find target which provides the specified name, and add a preflight.
469                # XXX: this only returns the first match, is this what we want?
470                set ident [lindex [dlist_get_matches targets provides $name] 0]
471                dlist_append_key targets $ident pre $args
472               
473    } elseif {[string equal postflight $mode]} {
474                # Find target which provides the specified name, and add a preflight.
475                # XXX: this only returns the first match, is this what we want?
476                set ident [lindex [dlist_get_matches targets provides $name] 0]
477                dlist_append_key targets $ident post $args
478        }
479}
480
481
482# unregister
483# Unregisters a target in the global target list
484# Arguments: target <target name>
485proc unregister {mode target} {
486}
487
488########### Internal Dependancy Manipulation Procedures ###########
489
490# Dependency List (dlist)
491# The dependency list is really just one big array.  (I would have
492# liked to make this nested arrays, but that's not feasible in Tcl,
493# thus we'll use the $fieldname,$groupname syntax to mimic structures.
494#
495# Dependency lists may contain private data, via the
496# dlist_*_key APIs.  However, it must be recognized that the
497# following keys are reserved for use by the evaluation engine.
498# (Don't fret, you want these keys anyway, honest.)  These keys also
499# have predefined accessor APIs to remind you of their significance.
500#
501# Reserved keys:
502# name          - The unique identifier of the item.  No Commas!
503# provides      - The list of tokens this item provides
504# requires      - The list of hard-dependency tokens
505# uses          - The list of soft-dependency tokens
506# runtype       - The runtype of the item {always,once}
507
508# Sets the key/value to an item in the dependency list
509proc dlist_set_key {dlist name key args} {
510    upvar $dlist uplist
511    # might be keen to validate $name here.
512    eval "set uplist($key,$name) $args"
513}
514
515# Appends the value to the list stored at the key of the item
516proc dlist_append_key {dlist name key args} {
517    upvar $dlist uplist
518    if {![dlist_has_key uplist $name $key]} { set uplist($key,$name) [list] }
519    eval "lappend uplist($key,$name) [join $args]"
520}
521
522# Return true if the key exists for the item, false otherwise
523proc dlist_has_key {dlist name key} {
524    upvar $dlist uplist
525    return [info exists uplist($key,$name)]
526}
527
528# Retrieves the value of the key of an item in the dependency list
529proc dlist_get_key {dlist name key} {
530    upvar $dlist uplist
531    if {[info exists uplist($key,$name)]} {
532        return $uplist($key,$name)
533    } else {
534        return ""
535    }
536}
537
538# Adds a colorless odorless item to the dependency list
539proc dlist_add_item {dlist name} {
540    upvar $dlist uplist
541    set uplist(name,$name) $name
542}
543
544# Deletes all keys of the specified item
545proc dlist_remove_item {dlist name} {
546    upvar $dlist uplist
547    array unset uplist *,$name
548}
549
550# Tests if the item is present in the dependency list
551proc dlist_has_item {dlist name} {
552    upvar $dlist uplist
553    return [info exists uplist(name,$name)]
554}
555
556# Return a list of names of items that provide the given name
557proc dlist_get_matches {dlist key value} {
558    upvar $dlist uplist
559    set result [list]
560    foreach ident [array names uplist name,*] {
561        set name $uplist($ident)
562        foreach val [dlist_get_key uplist $name $key] {
563            if {[string equal $val $value] && 
564                ![info exists ${result}($name)]} {
565                lappend result $name
566            }
567        }
568    }
569    return $result
570}
571
572# Count the unmet dependencies in the dlist based on the statusdict
573proc dlist_count_unmet {names statusdict} {
574    upvar $statusdict upstatusdict
575    set unmet 0
576    foreach name $names {
577        if {![info exists upstatusdict($name)] ||
578            ![string equal $upstatusdict($name) success]} {
579            incr unmet
580        }
581    }
582    return $unmet
583}
584
585# Returns true if any of the dependencies are pending in the dlist
586proc dlist_has_pending {dlist uses} {
587    foreach name $uses {
588        if {[info exists ${dlist}(name,$name)]} { 
589            return 1
590        }
591    }
592    return 0
593}
594
595# Get the name of the next eligible item from the dependency list
596proc dlist_get_next {dlist statusdict} {
597    set nextitem ""
598    # arbitrary large number ~ INT_MAX
599    set minfailed 2000000000
600    upvar $dlist uplist
601    upvar $statusdict upstatusdict
602   
603    foreach n [array names uplist name,*] {
604        set name $uplist($n)
605       
606        # skip if unsatisfied hard dependencies
607        if {[dlist_count_unmet [dlist_get_key uplist $name requires] upstatusdict]} { continue }
608       
609        # favor item with fewest unment soft dependencies
610        set unmet [dlist_count_unmet [dlist_get_key uplist $name uses] upstatusdict]
611       
612        # delay items with unmet soft dependencies that can be filled
613        if {$unmet > 0 && [dlist_has_pending dlist [dlist_get_key uplist $name uses]]} { continue }
614       
615        if {$unmet >= $minfailed} {
616            # not better than our last pick
617            continue
618        } else {
619            # better than our last pick
620            set minfailed $unmet
621            set nextitem $name
622        }
623    }
624    return $nextitem
625}
626
627
628# Evaluate the dlist, invoking action on each name in the dlist as it
629# becomes eligible.
630proc dlist_evaluate {dlist downstatusdict action} {
631    # dlist - nodes waiting to be executed
632    upvar $dlist uplist
633    upvar $downstatusdict statusdict
634   
635    # status - keys will be node names, values will be success or failure.
636    array set statusdict [list]
637   
638    # loop for as long as there are nodes in the dlist.
639    while (1) {
640        set name [dlist_get_next uplist statusdict]
641        if {[string length $name] == 0} { 
642            break
643        } else {
644            set result [eval $action uplist $name]
645            foreach token $uplist(provides,$name) {
646                array set statusdict [list $token $result]
647            }
648            dlist_remove_item uplist $name
649        }
650    }
651   
652    set names [array names uplist name,*]
653        if { [llength $names] > 0} {
654                # somebody broke!
655                ui_info "Warning: the following items did not execute: "
656                foreach name $names {
657                        ui_info "$uplist($name) " -nonewline
658                }
659                ui_info ""
660                return 1
661    }
662        return 0
663}
664
665proc exec_target {fd dlist name} {
666# XXX: Don't depend on entire dlist, this should really receive just one node.
667    upvar $dlist uplist
668
669    if {[dlist_has_key uplist $name procedure]} {
670                set procedure [dlist_get_key uplist $name procedure]
671                if {[dlist_has_key uplist $name init]} {
672                        [dlist_get_key uplist $name init] $name
673                }
674                               
675                if {[check_statefile $name $fd]} {
676                        set result 0
677                        ui_debug "Skipping completed $name"
678                } else {
679                        # Execute pre-run procedure
680                        if {[dlist_has_key uplist $name prerun]} {
681                                [dlist_get_key uplist $name prerun] $name
682                        }
683
684                        foreach pre [dlist_get_key uplist $name pre] {
685                                ui_debug "Executing $pre"
686                                if {[$pre $name] != 0} { return failure }
687                        }
688
689                        ui_debug "Executing $name"
690                        set result [$procedure $name]
691
692                        foreach post [dlist_get_key uplist $name post] {
693                                ui_debug "Executing $post"
694                                if {[$post $name] != 0} { 
695                                        set result 1 
696                                        break
697                                }
698                        }
699                        # Execute post-run procedure
700                        if {[dlist_has_key uplist $name postrun]} {
701                                [dlist_get_key uplist $name postrun] $name
702                        }
703                }
704                if {$result == 0} {
705                        set result success
706                        if {[dlist_get_key uplist $name runtype] != "always"} {
707                        write_statefile $name $fd
708                        }
709                } else {
710                        ui_error "Target error: $name returned $result"
711                        set result failure
712                }
713               
714    } else {
715                ui_info "Warning: $name does not have a registered procedure"
716                set result failure
717    }
718       
719    return $result
720}
721
722proc eval_targets {dlist target} {
723    upvar $dlist uplist
724
725    # Select the subset of targets under $target
726    if {[string length $target] > 0} {
727                # XXX munge target. install really means registry, then install
728                # If more than one target ever needs this, make this a generic interface
729                if {[string equal $target "install"]} {
730                        set target registry
731                }
732        set matches [dlist_get_matches uplist provides $target]
733        if {[llength $matches] > 0} {
734            array set dependents [list]
735            dlist_append_dependents dependents uplist [lindex $matches 0]
736            array unset uplist
737            array set uplist [array get dependents]
738            # Special-case 'all'
739        } elseif {![string equal $target all]} {
740            ui_error "unknown target: $target"
741            return 1
742        }
743    }
744   
745    array set statusdict [list]
746   
747    # Restore the state from a previous run.
748    set fd [open_statefile]
749   
750    set ret [dlist_evaluate uplist statusdict [list exec_target $fd]]
751
752    close $fd
753    return $ret
754}
755
756# select dependents of <name> from the <itemlist>
757# adding them to <dependents>
758proc dlist_append_dependents {dependents dlist name} {
759    upvar $dependents updependents
760    upvar $dlist uplist
761
762    # Append item to the list, avoiding duplicates
763    if {![info exists updependents(name,$name)]} {
764        set names [array names uplist *,$name]
765        foreach n $names {
766            set updependents($n) $uplist($n)
767        }
768    }
769   
770    # Recursively append any hard dependencies
771    if {[info exists uplist(requires,$name)]} {
772        foreach dep $uplist(requires,$name) {
773            foreach provide [dlist_get_matches uplist provides $dep] {
774                dlist_append_dependents updependents uplist $provide
775            }
776        }
777    }
778   
779    # XXX: add soft-dependencies?
780}
781
782# open_statefile
783# open file to store name of completed targets
784proc open_statefile {args} {
785    global portpath workdir
786
787    if ![file isdirectory $portpath/$workdir] {
788        file mkdir $portpath/$workdir
789    }
790    # flock Portfile
791    set statefile [file join $portpath $workdir .darwinports.state]
792    if {[file exists $statefile] && ![file writable $statefile]} {
793        return -code error "$statefile is not writable - check permission on port directory"
794    }
795    set fd [open $statefile a+]
796    if [catch {flock $fd -exclusive -noblock} result] {
797        if {"$result" == "EAGAIN"} {
798            ui_puts "Waiting for lock on $statefile"
799        } else {
800            return -code error "$result obtaining lock on $statefile"
801        }
802    }
803    flock $fd -exclusive
804    return $fd
805}
806
807# check_statefile
808# Check completed state of target $name
809proc check_statefile {name fd} {
810    global portpath workdir
811
812    seek $fd 0
813    while {[gets $fd line] >= 0} {
814        if {[string equal $line $name]} {
815            return 1
816        }
817    }
818    return 0
819}
820
821# write_statefile
822# Set target $name completed in the state file
823proc write_statefile {name fd} {
824    if {[check_statefile $name $fd]} {
825        return 0
826    }
827    seek $fd 0 end
828    puts $fd $name
829    flush $fd
830}
831
832# Traverse the ports collection hierarchy and call procedure func for
833# each directory containing a Portfile
834proc port_traverse {func {dir .}} {
835    set pwd [pwd]
836    if [catch {cd $dir} err] {
837        ui_error $err
838        return
839    }
840    foreach name [readdir .] {
841        if {[string match $name .] || [string match $name ..]} {
842            continue
843        }
844        if [file isdirectory $name] {
845            port_traverse $func $name
846        } else {
847            if [string match $name Portfile] {
848                catch {eval $func {[file join $pwd $dir]}}
849            }
850        }
851    }
852    cd $pwd
853}
854
855
856########### Port Variants ###########
857
858# Each variant which provides a subset of the requested variations
859# will be chosen.  Returns a list of the selected variants.
860proc choose_variants {variants variations} {
861    upvar $variants upvariants
862    upvar $variations upvariations
863
864    set selected [list]
865   
866    foreach n [array names upvariants name,*] {
867                set name $upvariants($n)
868               
869                # Enumerate through the provides, tallying the pros and cons.
870                set pros 0
871                set cons 0
872                set ignored 0
873                foreach flavor [dlist_get_key upvariants $name provides] {
874                        if {[info exists upvariations($flavor)]} {
875                                if {$upvariations($flavor) == "+"} {
876                                        incr pros
877                                } elseif {$upvariations($flavor) == "-"} {
878                                        incr cons
879                                }
880                        } else {
881                                incr ignored
882                        }
883                }
884               
885                if {$cons > 0} { continue }
886               
887                if {$pros > 0 && $ignored == 0} {
888                        lappend selected $name
889                }
890        }
891    return $selected
892}
893
894proc exec_variant {dlist name} {
895# XXX: Don't depend on entire dlist, this should really receive just one node.
896    upvar $dlist uplist
897    ui_debug "Executing $name"
898    makeuserproc $name-code "\{[dlist_get_key uplist $name procedure]\}"
899    $name-code
900    return success
901}
902
903proc eval_variants {dlist variations} {
904    upvar $dlist uplist
905        upvar $variations upvariations
906
907        set chosen [choose_variants uplist upvariations]
908
909    # now that we've selected variants, change all provides [a b c] to [a-b-c]
910    # this will eliminate ambiguity between item a, b, and a-b while fulfilling requirments.
911    foreach n [array names uplist provides,*] {
912        array set uplist [list $n [join $uplist($n) -]]
913    }
914       
915        array set dependents [list]
916    foreach variant $chosen {
917        dlist_append_dependents dependents uplist $variant
918    }
919        array unset uplist
920        array set uplist [array get dependents]
921   
922    array set statusdict [list]
923       
924    dlist_evaluate uplist statusdict [list exec_variant]
925}
Note: See TracBrowser for help on using the repository browser.