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

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

Allow darwinports to build on file systems that do not support flock (ie NFS)

  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 27.1 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        } elseif {"$result" == "ENOSUPP"} {
800            # Locking not supported, just return
801            return $fd
802        } else {
803            return -code error "$result obtaining lock on $statefile"
804        }
805    }
806    flock $fd -exclusive
807    return $fd
808}
809
810# check_statefile
811# Check completed state of target $name
812proc check_statefile {name fd} {
813    global portpath workdir
814
815    seek $fd 0
816    while {[gets $fd line] >= 0} {
817        if {[string equal $line $name]} {
818            return 1
819        }
820    }
821    return 0
822}
823
824# write_statefile
825# Set target $name completed in the state file
826proc write_statefile {name fd} {
827    if {[check_statefile $name $fd]} {
828        return 0
829    }
830    seek $fd 0 end
831    puts $fd $name
832    flush $fd
833}
834
835# Traverse the ports collection hierarchy and call procedure func for
836# each directory containing a Portfile
837proc port_traverse {func {dir .}} {
838    set pwd [pwd]
839    if [catch {cd $dir} err] {
840        ui_error $err
841        return
842    }
843    foreach name [readdir .] {
844        if {[string match $name .] || [string match $name ..]} {
845            continue
846        }
847        if [file isdirectory $name] {
848            port_traverse $func $name
849        } else {
850            if [string match $name Portfile] {
851                catch {eval $func {[file join $pwd $dir]}}
852            }
853        }
854    }
855    cd $pwd
856}
857
858
859########### Port Variants ###########
860
861# Each variant which provides a subset of the requested variations
862# will be chosen.  Returns a list of the selected variants.
863proc choose_variants {variants variations} {
864    upvar $variants upvariants
865    upvar $variations upvariations
866
867    set selected [list]
868   
869    foreach n [array names upvariants name,*] {
870                set name $upvariants($n)
871               
872                # Enumerate through the provides, tallying the pros and cons.
873                set pros 0
874                set cons 0
875                set ignored 0
876                foreach flavor [dlist_get_key upvariants $name provides] {
877                        if {[info exists upvariations($flavor)]} {
878                                if {$upvariations($flavor) == "+"} {
879                                        incr pros
880                                } elseif {$upvariations($flavor) == "-"} {
881                                        incr cons
882                                }
883                        } else {
884                                incr ignored
885                        }
886                }
887               
888                if {$cons > 0} { continue }
889               
890                if {$pros > 0 && $ignored == 0} {
891                        lappend selected $name
892                }
893        }
894    return $selected
895}
896
897proc exec_variant {dlist name} {
898# XXX: Don't depend on entire dlist, this should really receive just one node.
899    upvar $dlist uplist
900    ui_debug "Executing $name"
901    makeuserproc $name-code "\{[dlist_get_key uplist $name procedure]\}"
902    $name-code
903    return success
904}
905
906proc eval_variants {dlist variations} {
907    upvar $dlist uplist
908        upvar $variations upvariations
909
910        set chosen [choose_variants uplist upvariations]
911
912    # now that we've selected variants, change all provides [a b c] to [a-b-c]
913    # this will eliminate ambiguity between item a, b, and a-b while fulfilling requirments.
914    foreach n [array names uplist provides,*] {
915        array set uplist [list $n [join $uplist($n) -]]
916    }
917       
918        array set dependents [list]
919    foreach variant $chosen {
920        dlist_append_dependents dependents uplist $variant
921    }
922        array unset uplist
923        array set uplist [array get dependents]
924   
925    array set statusdict [list]
926       
927    dlist_evaluate uplist statusdict [list exec_variant]
928}
Note: See TracBrowser for help on using the repository browser.