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

Last change on this file since 796 was 796, checked in by kevin, 16 years ago

Change dependency evaluation engine to use depspec objects.

  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 26.7 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 targets [list]
38set target_uniqid 0
39
40set variants [list]
41
42########### External High Level Procedures ###########
43
44namespace eval options {
45}
46
47# options
48# Exports options in an array as externally callable procedures
49# Thus, "options name date" would create procedures named "name"
50# and "date" that set global variables "name" and "date", respectively
51# When an option is modified in any way, options::$option is called,
52# if it exists
53# Arguments: <list of options>
54proc options {args} {
55    foreach option $args {
56        eval "proc $option {args} \{ \n\
57            global ${option} user_options \n\
58                \if \{!\[info exists user_options(${option})\]\} \{ \n\
59                     set ${option} \$args \n\
60                         if \{\[info commands options::${option}\] != \"\"\} \{ \n\
61                             options::${option} ${option} \n\
62                         \} \n\
63                \} \n\
64        \}"
65
66        eval "proc ${option}-delete {args} \{ \n\
67            global ${option} user_options \n\
68                \if \{!\[info exists user_options(${option})\]\} \{ \n\
69                    foreach val \$args \{ \n\
70                        ldelete ${option} \$val \n\
71                    \} \n\
72                    if \{\[info commands options::${option}\] != \"\"\} \{ \n\
73                        options::${option} ${option} \n\
74                    \} \n\
75                \} \n\
76        \}"
77        eval "proc ${option}-append {args} \{ \n\
78            global ${option} user_options \n\
79                \if \{!\[info exists user_options(${option})\]\} \{ \n\
80                    set $option \[concat \$$option \$args\] \n\
81                        if \{\[info commands options::${option}\] != \"\"\} \{ \n\
82                            options::${option} ${option} \n\
83                        \} \n\
84                \} \n\
85        \}"
86    }
87}
88
89proc options_export {args} {
90    foreach option $args {
91        eval "proc options::${option} {args} \{ \n\
92            global ${option} PortInfo \n\
93                set PortInfo(${option}) \$${option}\n\
94        \}"
95    }
96}
97
98# commands
99# Accepts a list of arguments, of which several options are created
100# and used to form a standard set of command options.
101proc commands {args} {
102    foreach option $args {
103        options use_${option} ${option}.dir ${option}.pre_args ${option}.args ${option}.post_args ${option}.env ${option}.type ${option}.cmd
104    }
105}
106
107# command
108# Given a command name, command assembled a string
109# composed of the command options.
110proc command {command} {
111    global ${command}.dir ${command}.pre_args ${command}.args ${command}.post_args ${command}.env ${command}.type ${command}.cmd
112
113    set cmdstring ""
114    if [info exists ${command}.dir] {
115        set cmdstring "cd [set ${command}.dir] &&"
116    }
117
118    if [info exists ${command}.env] {
119        foreach string [set ${command}.env] {
120                set cmdstring "$cmdstring $string"
121        }
122    }
123
124    if [info exists ${command}.cmd] {
125        foreach string [set ${command}.cmd] {
126                set cmdstring "$cmdstring $string"
127        }
128    } else {
129        set cmdstring "$cmdstring ${command}"
130    }
131    foreach var "${command}.pre_args ${command}.args ${command}.post_args" {
132        if [info exists $var] {
133        foreach string [set ${var}] {
134                set cmdstring "$cmdstring $string"
135        }
136        }
137    }
138    ui_debug "Assembled command: '$cmdstring'"
139    return $cmdstring
140}
141
142# default
143# Sets a variable to the supplied default if it does not exist,
144# and adds a variable trace. The variable traces allows for delayed
145# variable and command expansion in the variable's default value.
146proc default {option val} {
147    global $option option_defaults
148        if {[info exists option_defaults($option)]} {
149                ui_debug "Re-registering default for $option"
150        } else {
151                # If option is already set and we did not set it
152                # do not reset the value
153                if {[info exists $option]} {
154                        return
155                }
156        }
157        set option_defaults($option) $val
158        set $option $val
159        trace variable $option rwu default_check
160}
161
162# default_check
163# trace handler to provide delayed variable & command expansion
164# for default variable values
165proc default_check {optionName index op} {
166        global option_defaults $optionName
167        switch $op {
168                w {
169                        unset option_defaults($optionName)
170                        trace vdelete $optionName rwu default_check
171                        return
172                }
173                r {
174                        upvar $optionName option
175                        uplevel #0 set $optionName $option_defaults($optionName)
176                        return
177                }
178                u {
179                        unset option_defaults($optionName)
180                        trace vdelete $optionName rwu default_check
181                        return
182                }
183        }
184}
185
186# variant <provides> [<provides> ...] [requires <requires> [<requires>]]
187# Portfile level procedure to provide support for declaring variants
188proc variant {args} {
189    global variants PortInfo
190    upvar $args upargs
191   
192    set len [llength $args]
193    set code [lindex $args end]
194    set args [lrange $args 0 [expr $len - 2]]
195   
196    set provides [list]
197    set requires [list]
198   
199    # halfway through the list we'll hit 'requires' which tells us
200    # to switch into processing required flavors/depspecs.
201    set after_requires 0
202    foreach arg $args {
203        if ([string equal $arg requires]) { 
204            set after_requires 1
205            continue
206        }
207        if ($after_requires) {
208            lappend requires $arg
209        } else {
210            lappend provides $arg
211        }
212    }
213    set name "variant-[join $provides -]"
214    set obj [variant_new $name]
215    $obj append provides $provides
216    $obj append requires $requires
217    $obj set code $code
218        lappend variants $obj
219
220    # Export provided variant to PortInfo
221    lappend PortInfo(variants) $provides
222}
223
224# variant_isset name
225# Returns 1 if variant name selected, otherwise 0
226proc variant_isset {name} {
227    global variations
228
229    if {[info exists variations($name)] && $variations($name) == "+"} {
230        return 1
231    }
232    return 0
233}
234
235# variant_set name
236# Sets variant to run for current portfile
237proc variant_set {name} {
238    global variations
239
240    set variations($name) +
241}
242
243# variant_unset name
244# Clear variant for current portfile
245proc variant_unset {name} {
246    global variations
247
248    set variations($name) -
249}
250
251########### Misc Utility Functions ###########
252
253# tbool (testbool)
254# If the variable exists in the calling procedure's namespace
255# and is set to "yes", return 1. Otherwise, return 0
256proc tbool {key} {
257    upvar $key $key
258    if {[info exists $key]} {
259        if {[string equal -nocase [set $key] "yes"]} {
260            return 1
261        }
262    }
263    return 0
264}
265
266# ldelete
267# Deletes a value from the supplied list
268proc ldelete {list value} {
269    upvar $list uplist
270    set ix [lsearch -exact uplist $value]
271    if {$ix >= 0} {
272        set uplist [lreplace uplist $ix $ix]
273    }
274}
275
276# reinplace
277# Provides "sed in place" functionality
278proc reinplace {oddpattern file}  {
279    set backpattern [strsed $oddpattern {g/\//\\\\\//}]
280    set pattern [strsed $backpattern {g/\|/\//}]
281
282    if {[catch {set input [open "$file" RDWR]} error]} {
283        ui_error "reinplace: $error"
284        return -code error "reinplace failed"
285    }
286
287    if {[catch {set result [mkstemp "/tmp/[file tail $file].sed.XXXXXXXX"]} error]} {
288        ui_error "reinplace: $error"
289        close $input
290        return -code error "reinplace failed"
291    }
292
293    set output [lindex $result 0]
294    set tmpfile [lindex $result 1]
295
296    if {[catch {exec sed $pattern <@$input >@$output} error]} {
297        ui_error "reinplace: $error"
298        close $output
299        close $input
300        file delete "$tmpfile"
301        return -code error "reinplace failed"
302    }
303
304    seek $output 0
305    seek $input 0
306
307    if {[catch {exec cat <@$output >@$input 2>/dev/null} error]} {
308        ui_error "reinplace: $error"
309        close $output
310        close $input
311        file delete "$tmpfile"
312        return -code error "reinplace failed"
313    }
314
315    close $output
316    close $input
317    file delete "$tmpfile"
318    return
319}
320
321# filefindbypath
322# Provides searching of the standard path for included files
323proc filefindbypath {fname} {
324    global distpath filedir workdir worksrcdir portpath
325
326    if [file readable $fname] {
327        return $fname
328    } elseif [file readable $portpath/$fname] {
329        return $portpath/$fname
330    } elseif [file readable $portpath/$filedir/$fname] {
331        return $portpath/$filedir/$fname
332    } elseif [file readable $distpath/$fname] {
333        return $distpath/$fname
334    } elseif [file readable $portpath/$workdir/$worksrcdir/$fname] {
335        return $portpath/$workdir/$worksrcdir/$fname
336    } elseif [file readable [file join /etc $fname]] {
337        return [file join /etc $fname]
338    }
339    return ""
340}
341
342# include
343# Source a file, looking for it along a standard search path.
344proc include {fname} {
345    set tgt [filefindbypath $fname]
346    if [string length $tgt] {
347        uplevel "source $tgt"
348    } else {
349        return -code error "Unable to find include file $fname"
350    }
351}
352
353# makeuserproc
354# This procedure re-writes the user-defined custom target to include
355# all the globals in its scope.  This is undeniably ugly, but I haven't
356# thought of any other way to do this.
357proc makeuserproc {name body} {
358    regsub -- "^\{(.*)" $body "\{ \n foreach g \[info globals\] \{ \n global \$g \n \} \n \\1 " body
359    eval "proc $name {} $body"
360}
361
362########### External Dependancy Manipulation Procedures ###########
363# register
364# Creates a target in the global target list using the internal dependancy
365#     functions
366# Arguments: <identifier> <mode> <args ...>
367# The following modes are supported:
368#       <identifier> target <procedure to execute> [run type]
369#       <identifier> init <procedure to execute>
370#       <identifier> prerun <procedure to execute>
371#       <identifier> postrun <procedure to execute>
372#       <identifier> provides <list of target names>
373#       <identifier> requires <list of target names>
374#       <identifier> uses <list of target names>
375#       <provides> preflight <proc name>
376#       <provides> postflight <proc name>
377proc register {name mode args} {
378    global targets target_uniqid
379   
380        set obj [dlist_get_by_name $targets $name]
381        if {$obj == ""} {
382                set obj [target_new $name]
383                lappend targets $obj
384        }
385
386    if {$mode == "target"} {
387        set procedure [lindex $args 0]
388        if {[$obj has procedure]} {
389            ui_debug "Warning: target '$name' re-registered (new procedure: '$procedure')"
390        }
391        $obj set procedure $procedure
392               
393                # Set runtype {always,once} if available
394                if {[llength $args] >= 2} {
395                        $obj set runtype [lindex $args 1]
396                }
397    } elseif {$mode == "init"} {
398                set init [lindex $args 0]
399                if {[$obj has init]} {
400                        ui_debug "Warning: target '$name' re-registered init procedure (new procedure: '$init')"
401                }
402                $obj set init $init
403    } elseif {$mode == "prerun"} {
404                set prerun [lindex $args 0]
405                if {[$obj has prerun]} {
406                        ui_debug "Warning: target '$name' re-registered pre-run procedure (new procedure: '$prerun')"
407                }
408                $obj prerun $prerun
409    } elseif {$mode == "postrun"} {
410                set postrun [lindex $args 0]
411                if {[$obj has postrun]} {
412                        ui_debug "Warning: target '$name' re-registered post-run procedure (new procedure: '$postrun')"
413                }
414                $obj set postrun $postrun
415    } elseif {$mode == "requires" || $mode == "uses" || $mode == "provides"} {
416                $obj append $mode $args
417       
418        if {$mode == "provides"} {
419            # If it's a provides, register the pre-/post- hooks for use in Portfile.
420            # Portfile syntax: pre-fetch { puts "hello world" }
421            # User-code exceptions are caught and returned as a result of the target.
422            # Thus if the user code breaks, dependent targets will not execute.
423            foreach target $args {
424                                if {[info commands $target] != ""} {
425                                        ui_error "$name attempted to register provide \'$target\' which is a pre-existing procedure. Ignoring register."
426                                        continue;
427                                }
428                set ident [lindex [depspec_get_matches $targets provides $args] 0]
429                set origproc [$ident get procedure]
430                eval "proc $target {args} \{ \n\
431                                        global target_uniqid \n\
432                                        set id \[incr target_uniqid\] \n\
433                    register $ident target proc-$target\$id \n\
434                    eval \"proc proc-$target\$id \{name\} \{ \n\
435                        if \\\[catch userproc-$target\$id result\\\] \{ \n\
436                                                        ui_info \\\$result \n\
437                                                        return 1 \n\
438                                                \} else \{ \n\
439                                                        return 0 \n\
440                                                \} \n\
441                    \}\" \n\
442                    eval \"proc do-$target \{\} \{ $origproc $target\}\" \n\
443                    makeuserproc userproc-$target\$id \$args \}"
444                eval "proc pre-$target {args} \{ \n\
445                                        global target_uniqid \n\
446                                        set id \[incr target_uniqid\] \n\
447                    register $target preflight pre-$target\$id \n\
448                    eval \"proc pre-$target\$id \{name\} \{ \n\
449                        if \\\[catch userproc-pre-$target\$id result\\\] \{ \n\
450                                                        ui_info \\\$result \n\
451                                                        return 1 \n\
452                                                \} else \{ \n\
453                                                        return 0 \n\
454                                                \} \n\
455                    \}\" \n\
456                    makeuserproc userproc-pre-$target\$id \$args \}"
457                eval "proc post-$target {args} \{ \n\
458                                        global target_uniqid \n\
459                                        set id \[incr target_uniqid\] \n\
460                    register $target postflight post-$target\$id \n\
461                    eval \"proc post-$target\$id \{name\} \{ \n\
462                        if \\\[catch userproc-post-$target\$id result\\\] \{ \n\
463                                                        ui_info \\\$result \n\
464                                                        return 1 \n\
465                                                \} else \{ \n\
466                                                        return 0 \n\
467                                                \} \n\
468                    \}\" \n\
469                    makeuserproc userproc-post-$target\$id \$args \}"
470            }
471        }
472       
473    } elseif {$mode == "preflight"} {
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 obj [lindex [depspec_get_matches $targets provides $name] 0]
477                $obj append pre $args
478               
479    } elseif {$mode == "postflight"} {
480                # Find target which provides the specified name, and add a preflight.
481                # XXX: this only returns the first match, is this what we want?
482                set obj [lindex [depspec_get_matches $targets provides $name] 0]
483                $obj post $args
484        }
485}
486
487
488# unregister
489# Unregisters a target in the global target list
490# Arguments: target <target name>
491proc unregister {mode target} {
492}
493
494########### Internal Dependancy Manipulation Procedures ###########
495
496# returns a depspec by name
497proc dlist_get_by_name {dlist name} {
498        set result ""
499        foreach d $dlist {
500                if {[$d get name] == $name} {
501                        set result $d
502                        break
503                }
504        }
505        return $result
506}
507
508# returns a list of depspecs that contain the given name in the given key
509proc depspec_get_matches {dlist key value} {
510    set result [list]
511    foreach d $dlist {
512                foreach val [$d get $key] {
513                        if {$val == $value} {
514                                lappend result $d
515                        }
516                }
517    }
518    return $result
519}
520
521# Count the unmet dependencies in the dlist based on the statusdict
522proc dlist_count_unmet {dlist statusdict names} {
523    upvar $statusdict upstatusdict
524    set unmet 0
525    foreach name $names {
526                # Service was provided, check next.
527                if {[info exists upstatusdict($name)] && $upstatusdict($name) == 1} {
528                        continue
529                } else {
530                        incr unmet
531                }
532    }
533    return $unmet
534}
535
536# Returns true if any of the dependencies are pending in the dlist
537proc dlist_has_pending {dlist uses} {
538    foreach name $uses {
539                if {[llength [depspec_get_matches $dlist provides $name]] > 0} {
540                        return 1
541                }
542    }
543    return 0
544}
545
546# Get the name of the next eligible item from the dependency list
547proc generic_get_next {dlist statusdict} {
548    set nextitem ""
549    # arbitrary large number ~ INT_MAX
550    set minfailed 2000000000
551    upvar $statusdict upstatusdict
552   
553    foreach obj $dlist {               
554                # skip if unsatisfied hard dependencies
555                if {[dlist_count_unmet $dlist upstatusdict [$obj get requires]]} { continue }
556               
557                # favor item with fewest unment soft dependencies
558                set unmet [dlist_count_unmet $dlist upstatusdict [$obj get uses]]
559
560                # delay items with unmet soft dependencies that can be filled
561                if {$unmet > 0 && [dlist_has_pending $dlist [$obj get 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 $obj
570                }
571    }
572    return $nextitem
573}
574
575
576# Evaluate the list of depspecs, running each as it becomes eligible.
577# dlist is a collection of depspec objects to be run
578# get_next_proc is used to determine the best item to run
579proc dlist_evaluate {dlist get_next_proc} {
580
581    # status - keys will be node names, values will be {-1, 0, 1}.
582    array set statusdict [list]
583       
584        # XXX: Do we want to evaluate this dynamically instead of statically?
585        foreach obj $dlist {
586                if {[$obj test] == 1} {
587                        foreach name [$obj get provides] {
588                                set statusdict($name) 1
589                        }
590                }
591        }
592   
593    # loop for as long as there are nodes in the dlist.
594    while (1) {
595                set obj [$get_next_proc $dlist statusdict]
596
597                if {$obj == ""} { 
598                        break
599                } else {
600                        set result [$obj run]
601                        # depspec->run returns an error code, so 0 == success.
602                        # translate this to the statusdict notation where 1 == success.
603                        foreach name [$obj get provides] {
604                                set statusdict($name) [expr $result == 0]
605                        }
606                       
607                        # Delete the item from the waiting list.
608                        set i [lsearch $dlist $obj]
609                        set dlist [lreplace $dlist $i $i]
610                }
611    }
612   
613        if {[llength $dlist] > 0} {
614                # somebody broke!
615                ui_info "Warning: the following items did not execute: "
616                foreach obj $dlist {
617                        ui_info "[$obj get name] " -nonewline
618                }
619                ui_info ""
620                return 1
621    }
622        return 0
623}
624
625proc target_run {this} {
626        global target_state_fd
627        set procedure [$this get procedure]
628    if {$procedure != ""} {
629                set name [$this get name]
630       
631                if {[$this has init]} {
632                        [$this get init] $name
633                }
634                               
635                if {[check_statefile $name $target_state_fd]} {
636                        set result 0
637                        ui_debug "Skipping completed $name"
638                } else {
639                        # Execute pre-run procedure
640                        if {[$this has prerun]} {
641                                [$this get prerun] $name
642                        }
643
644                        foreach pre [$this get pre] {
645                                ui_debug "Executing $pre"
646                                if {[$pre $name] != 0} { return failure }
647                        }
648
649                        ui_debug "Executing $name"
650                        set result [$procedure $name]
651
652                        foreach post [$this get post] {
653                                ui_debug "Executing $post"
654                                if {[$post $name] != 0} { 
655                                        set result 1 
656                                        break
657                                }
658                        }
659                        # Execute post-run procedure
660                        if {[$this has postrun]} {
661                                set postrun [$this get postrun]
662                                ui_debug "Executing $postrun"
663                                $postrun $name
664                        }
665                }
666                if {$result == 0} {
667                        set result 0
668                        if {[$this get runtype] != "always"} {
669                                write_statefile $name $target_state_fd
670                        }
671                } else {
672                        ui_error "Target error: $name returned $result"
673                        set result 1
674                }
675               
676    } else {
677                ui_info "Warning: $name does not have a registered procedure"
678                set result 1
679    }
680
681    return $result
682}
683
684proc eval_targets {target} {
685        global targets target_state_fd
686        set dlist $targets
687
688    # Select the subset of targets under $target
689    if {$target != ""} {
690                # XXX munge target. install really means registry, then install
691                # If more than one target ever needs this, make this a generic interface
692                if {$target == "install"} {
693                        set target registry
694                }
695        set matches [depspec_get_matches $dlist provides $target]
696        if {[llength $matches] > 0} {
697                        set dlist [dlist_append_dependents $dlist [lindex $matches 0] [list]]
698                # Special-case 'all'
699        } elseif {$target != "all"} {
700            ui_info "unknown target: $target"
701            return 1
702        }
703    }
704       
705    # Restore the state from a previous run.
706    set target_state_fd [open_statefile]
707   
708    set ret [dlist_evaluate $dlist generic_get_next]
709
710    close $target_state_fd
711        return $ret
712}
713
714# returns the names of dependents of <name> from the <itemlist>
715proc dlist_append_dependents {dlist obj result} {
716
717        # Append the item to the list, avoiding duplicates
718        if {[lsearch $result $obj] == -1} {
719                lappend result $obj
720        }
721       
722    # Recursively append any hard dependencies
723        foreach dep [$obj get requires] {
724                foreach provider [depspec_get_matches $dlist provides $dep] {
725                        set result [dlist_append_dependents $dlist $provider $result]
726        }
727    }
728    # XXX: add soft-dependencies?
729        return $result
730}
731
732# open_statefile
733# open file to store name of completed targets
734proc open_statefile {args} {
735    global portpath workdir
736
737    if ![file isdirectory $portpath/$workdir] {
738        file mkdir $portpath/$workdir
739    }
740    # flock Portfile
741    set statefile [file join $portpath $workdir .darwinports.state]
742    if {[file exists $statefile] && ![file writable $statefile]} {
743        return -code error "$statefile is not writable - check permission on port directory"
744    }
745    set fd [open $statefile a+]
746    if [catch {flock $fd -exclusive -noblock} result] {
747        if {"$result" == "EAGAIN"} {
748            ui_puts "Waiting for lock on $statefile"
749        } elseif {"$result" == "EOPNOTSUPP"} {
750            # Locking not supported, just return
751            return $fd
752        } else {
753            return -code error "$result obtaining lock on $statefile"
754        }
755    }
756    flock $fd -exclusive
757    return $fd
758}
759
760# check_statefile
761# Check completed state of target $name
762proc check_statefile {name fd} {
763    global portpath workdir
764
765    seek $fd 0
766    while {[gets $fd line] >= 0} {
767        if {[string equal $line $name]} {
768            return 1
769        }
770    }
771    return 0
772}
773
774# write_statefile
775# Set target $name completed in the state file
776proc write_statefile {name fd} {
777    if {[check_statefile $name $fd]} {
778        return 0
779    }
780    seek $fd 0 end
781    puts $fd $name
782    flush $fd
783}
784
785# Traverse the ports collection hierarchy and call procedure func for
786# each directory containing a Portfile
787proc port_traverse {func {dir .}} {
788    set pwd [pwd]
789    if [catch {cd $dir} err] {
790        ui_error $err
791        return
792    }
793    foreach name [readdir .] {
794        if {[string match $name .] || [string match $name ..]} {
795            continue
796        }
797        if [file isdirectory $name] {
798            port_traverse $func $name
799        } else {
800            if [string match $name Portfile] {
801                catch {eval $func {[file join $pwd $dir]}}
802            }
803        }
804    }
805    cd $pwd
806}
807
808
809########### Port Variants ###########
810
811# Each variant which provides a subset of the requested variations
812# will be chosen.  Returns a list of the selected variants.
813proc choose_variants {dlist variations} {
814    upvar $variations upvariations
815
816    set selected [list]
817   
818    foreach obj $dlist {
819                # Enumerate through the provides, tallying the pros and cons.
820                set pros 0
821                set cons 0
822                set ignored 0
823                foreach flavor [$obj get provides] {
824                        if {[info exists upvariations($flavor)]} {
825                                if {$upvariations($flavor) == "+"} {
826                                        incr pros
827                                } elseif {$upvariations($flavor) == "-"} {
828                                        incr cons
829                                }
830                        } else {
831                                incr ignored
832                        }
833                }
834               
835                if {$cons > 0} { continue }
836               
837                if {$pros > 0 && $ignored == 0} {
838                        lappend selected $obj
839                }
840        }
841    return $selected
842}
843
844proc variant_run {this} {
845        set name [$this get name]
846    ui_debug "Executing $name provides [$this get provides]"
847    makeuserproc $name-code "\{[$this get code]\}"
848    if ([catch $name-code result]) {
849                ui_error "Error executing $name: $result"
850                return 1
851        }
852    return 0
853}
854
855proc eval_variants {variations} {
856        global variants
857        set dlist $variants
858        upvar $variations upvariations
859        set chosen [choose_variants $dlist upvariations]
860   
861        # now that we've selected variants, change all provides [a b c] to [a-b-c]
862    # this will eliminate ambiguity between item a, b, and a-b while fulfilling requirments.
863    #foreach obj $dlist {
864    #    $obj set provides [list [join [$obj get provides] -]]
865    #}
866       
867        set newlist [list]
868    foreach variant $chosen {
869        set newlist [dlist_append_dependents $dlist $variant $newlist]
870    }
871
872    dlist_evaluate $newlist generic_get_next
873}
874
875##### DEPSPEC #####
876
877# Object-Oriented Depspecs
878#
879# Each depspec will have its data stored in an array
880# (indexed by field name) and its procedures will be
881# called via the dispatch procedure that is returned
882# from depspec_new.
883#
884# sample usage:
885# set obj [depspec_new]
886# $obj set name "hello"
887#
888
889# Depspec
890#       str name
891#       str provides[]
892#       str requires[]
893#       str uses[]
894
895global depspec_uniqid
896set depspec_uniqid 0
897
898# Depspec class definition.
899global depspec_vtbl
900set depspec_vtbl(test) depspec_test
901set depspec_vtbl(run) depspec_run
902
903# constructor for abstract depspec class
904proc depspec_new {name} {
905        global depspec_uniqid
906        set id [incr depspec_uniqid]
907       
908        # declare the array of data
909        set data dpspc_data_${id}
910        set disp dpspc_disp_${id}
911       
912        global $data 
913        set ${data}(name) $name
914        set ${data}(_vtbl) depspec_vtbl
915       
916        eval "proc $disp {method args} { \n \
917                        global $data \n \
918                        eval return \\\[depspec_dispatch $disp $data \$method \$args\\\] \n \
919                }"
920       
921        return $disp
922}
923
924# is the only proc to get access to the object's data
925# so the get/set routines are defined here.  this lets
926# the virtual members get a real "this" object.
927proc depspec_dispatch {this data method args} {
928        global $data
929        switch $method {
930                get {
931                        set prop [lindex $args 0]
932                        if {[eval info exists ${data}($prop)]} {
933                                eval return $${data}($prop)
934                        } else {
935                                return ""
936                        }
937                }
938                set {
939                        set prop [lindex $args 0]
940                        eval "set ${data}($prop) [lrange $args 1 end]"
941                }
942                has {
943                        set prop [lindex $args 0]
944                        return [info exists ${data}($prop)]
945                }
946                append {
947                        set prop [lindex $args 0]
948                        set vals [join [lrange $args 1 end] " "]
949                        eval "lappend ${data}($prop) $vals"
950                }
951                default {
952                        eval set vtbl $${data}(_vtbl)
953                        global $vtbl
954                        if {[info exists ${vtbl}($method)]} {
955                                eval set function $${vtbl}($method)
956                                eval "return \[$function $this $args\]"
957                        } else {
958                                ui_error "unknown method: $method"
959                        }
960                }
961        }
962        return ""
963}
964
965proc depspec_test {this} {
966        return 0
967}
968
969proc depspec_run {this} {
970        return 0
971}
972
973##### target depspec subclass #####
974
975# Target class definition.
976global target_vtbl
977array set target_vtbl [array get depspec_vtbl]
978set target_vtbl(run) target_run
979
980# constructor for target depspec class
981proc target_new {name} {
982        set obj [depspec_new $name]
983       
984        $obj set _vtbl target_vtbl
985
986        return $obj
987}
988
989##### variant depspec subclass #####
990
991# Variant class definition.
992global variant_vtbl
993array set variant_vtbl [array get depspec_vtbl]
994set variant_vtbl(run) variant_run
995
996# constructor for target depspec class
997proc variant_new {name} {
998        set obj [depspec_new $name]
999       
1000        $obj set _vtbl variant_vtbl
1001
1002        return $obj
1003}
1004
1005
1006
1007##### bin portfile depspec subclass #####
Note: See TracBrowser for help on using the repository browser.