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

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

Fix pre/post/override target procs.

  • 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                                set ident [$ident get name]
431                eval "proc $target {args} \{ \n\
432                                        global target_uniqid \n\
433                                        set id \[incr target_uniqid\] \n\
434                    register $ident target proc-$target\$id \n\
435                    eval \"proc proc-$target\$id \{name\} \{ \n\
436                        if \\\[catch userproc-$target\$id result\\\] \{ \n\
437                                                        ui_info \\\$result \n\
438                                                        return 1 \n\
439                                                \} else \{ \n\
440                                                        return 0 \n\
441                                                \} \n\
442                    \}\" \n\
443                    eval \"proc do-$target \{\} \{ $origproc $target\}\" \n\
444                    makeuserproc userproc-$target\$id \$args \}"
445                eval "proc pre-$target {args} \{ \n\
446                                        global target_uniqid \n\
447                                        set id \[incr target_uniqid\] \n\
448                    register $target preflight pre-$target\$id \n\
449                    eval \"proc pre-$target\$id \{name\} \{ \n\
450                        if \\\[catch userproc-pre-$target\$id result\\\] \{ \n\
451                                                        ui_info \\\$result \n\
452                                                        return 1 \n\
453                                                \} else \{ \n\
454                                                        return 0 \n\
455                                                \} \n\
456                    \}\" \n\
457                    makeuserproc userproc-pre-$target\$id \$args \}"
458                eval "proc post-$target {args} \{ \n\
459                                        global target_uniqid \n\
460                                        set id \[incr target_uniqid\] \n\
461                    register $target postflight post-$target\$id \n\
462                    eval \"proc post-$target\$id \{name\} \{ \n\
463                        if \\\[catch userproc-post-$target\$id result\\\] \{ \n\
464                                                        ui_info \\\$result \n\
465                                                        return 1 \n\
466                                                \} else \{ \n\
467                                                        return 0 \n\
468                                                \} \n\
469                    \}\" \n\
470                    makeuserproc userproc-post-$target\$id \$args \}"
471            }
472        }
473       
474    } elseif {$mode == "preflight"} {
475                # Find target which provides the specified name, and add a preflight.
476                # XXX: this only returns the first match, is this what we want?
477                set obj [lindex [depspec_get_matches $targets provides $name] 0]
478                $obj append pre $args
479               
480    } elseif {$mode == "postflight"} {
481                # Find target which provides the specified name, and add a preflight.
482                # XXX: this only returns the first match, is this what we want?
483                set obj [lindex [depspec_get_matches $targets provides $name] 0]
484                $obj append post $args
485        }
486}
487
488
489# unregister
490# Unregisters a target in the global target list
491# Arguments: target <target name>
492proc unregister {mode target} {
493}
494
495########### Internal Dependancy Manipulation Procedures ###########
496
497# returns a depspec by name
498proc dlist_get_by_name {dlist name} {
499        set result ""
500        foreach d $dlist {
501                if {[$d get name] == $name} {
502                        set result $d
503                        break
504                }
505        }
506        return $result
507}
508
509# returns a list of depspecs that contain the given name in the given key
510proc depspec_get_matches {dlist key value} {
511    set result [list]
512    foreach d $dlist {
513                foreach val [$d get $key] {
514                        if {$val == $value} {
515                                lappend result $d
516                        }
517                }
518    }
519    return $result
520}
521
522# Count the unmet dependencies in the dlist based on the statusdict
523proc dlist_count_unmet {dlist statusdict names} {
524    upvar $statusdict upstatusdict
525    set unmet 0
526    foreach name $names {
527                # Service was provided, check next.
528                if {[info exists upstatusdict($name)] && $upstatusdict($name) == 1} {
529                        continue
530                } else {
531                        incr unmet
532                }
533    }
534    return $unmet
535}
536
537# Returns true if any of the dependencies are pending in the dlist
538proc dlist_has_pending {dlist uses} {
539    foreach name $uses {
540                if {[llength [depspec_get_matches $dlist provides $name]] > 0} {
541                        return 1
542                }
543    }
544    return 0
545}
546
547# Get the name of the next eligible item from the dependency list
548proc generic_get_next {dlist statusdict} {
549    set nextitem ""
550    # arbitrary large number ~ INT_MAX
551    set minfailed 2000000000
552    upvar $statusdict upstatusdict
553   
554    foreach obj $dlist {               
555                # skip if unsatisfied hard dependencies
556                if {[dlist_count_unmet $dlist upstatusdict [$obj get requires]]} { continue }
557               
558                # favor item with fewest unment soft dependencies
559                set unmet [dlist_count_unmet $dlist upstatusdict [$obj get uses]]
560
561                # delay items with unmet soft dependencies that can be filled
562                if {$unmet > 0 && [dlist_has_pending $dlist [$obj get uses]]} { continue }
563               
564                if {$unmet >= $minfailed} {
565                        # not better than our last pick
566                        continue
567                } else {
568                        # better than our last pick
569                        set minfailed $unmet
570                        set nextitem $obj
571                }
572    }
573    return $nextitem
574}
575
576
577# Evaluate the list of depspecs, running each as it becomes eligible.
578# dlist is a collection of depspec objects to be run
579# get_next_proc is used to determine the best item to run
580proc dlist_evaluate {dlist get_next_proc} {
581
582    # status - keys will be node names, values will be {-1, 0, 1}.
583    array set statusdict [list]
584       
585        # XXX: Do we want to evaluate this dynamically instead of statically?
586        foreach obj $dlist {
587                if {[$obj test] == 1} {
588                        foreach name [$obj get provides] {
589                                set statusdict($name) 1
590                        }
591                }
592        }
593   
594    # loop for as long as there are nodes in the dlist.
595    while (1) {
596                set obj [$get_next_proc $dlist statusdict]
597
598                if {$obj == ""} { 
599                        break
600                } else {
601                        set result [$obj run]
602                        # depspec->run returns an error code, so 0 == success.
603                        # translate this to the statusdict notation where 1 == success.
604                        foreach name [$obj get provides] {
605                                set statusdict($name) [expr $result == 0]
606                        }
607                       
608                        # Delete the item from the waiting list.
609                        set i [lsearch $dlist $obj]
610                        set dlist [lreplace $dlist $i $i]
611                }
612    }
613   
614        if {[llength $dlist] > 0} {
615                # somebody broke!
616                ui_info "Warning: the following items did not execute: "
617                foreach obj $dlist {
618                        ui_info "[$obj get name] " -nonewline
619                }
620                ui_info ""
621                return 1
622    }
623        return 0
624}
625
626proc target_run {this} {
627        global target_state_fd
628        set procedure [$this get procedure]
629    if {$procedure != ""} {
630                set name [$this get name]
631       
632                if {[$this has init]} {
633                        [$this get init] $name
634                }
635                               
636                if {[check_statefile $name $target_state_fd]} {
637                        set result 0
638                        ui_debug "Skipping completed $name"
639                } else {
640                        # Execute pre-run procedure
641                        if {[$this has prerun]} {
642                                [$this get prerun] $name
643                        }
644
645                        foreach pre [$this get pre] {
646                                ui_debug "Executing $pre"
647                                if {[$pre $name] != 0} { return failure }
648                        }
649
650                        ui_debug "Executing $name"
651                        set result [$procedure $name]
652
653                        foreach post [$this get post] {
654                                ui_debug "Executing $post"
655                                if {[$post $name] != 0} { 
656                                        set result 1 
657                                        break
658                                }
659                        }
660                        # Execute post-run procedure
661                        if {[$this has postrun]} {
662                                set postrun [$this get postrun]
663                                ui_debug "Executing $postrun"
664                                $postrun $name
665                        }
666                }
667                if {$result == 0} {
668                        set result 0
669                        if {[$this get runtype] != "always"} {
670                                write_statefile $name $target_state_fd
671                        }
672                } else {
673                        ui_error "Target error: $name returned $result"
674                        set result 1
675                }
676               
677    } else {
678                ui_info "Warning: $name does not have a registered procedure"
679                set result 1
680    }
681
682    return $result
683}
684
685proc eval_targets {target} {
686        global targets target_state_fd
687        set dlist $targets
688
689    # Select the subset of targets under $target
690    if {$target != ""} {
691                # XXX munge target. install really means registry, then install
692                # If more than one target ever needs this, make this a generic interface
693                if {$target == "install"} {
694                        set target registry
695                }
696        set matches [depspec_get_matches $dlist provides $target]
697        if {[llength $matches] > 0} {
698                        set dlist [dlist_append_dependents $dlist [lindex $matches 0] [list]]
699                # Special-case 'all'
700        } elseif {$target != "all"} {
701            ui_info "unknown target: $target"
702            return 1
703        }
704    }
705       
706    # Restore the state from a previous run.
707    set target_state_fd [open_statefile]
708   
709    set ret [dlist_evaluate $dlist generic_get_next]
710
711    close $target_state_fd
712        return $ret
713}
714
715# returns the names of dependents of <name> from the <itemlist>
716proc dlist_append_dependents {dlist obj result} {
717
718        # Append the item to the list, avoiding duplicates
719        if {[lsearch $result $obj] == -1} {
720                lappend result $obj
721        }
722       
723    # Recursively append any hard dependencies
724        foreach dep [$obj get requires] {
725                foreach provider [depspec_get_matches $dlist provides $dep] {
726                        set result [dlist_append_dependents $dlist $provider $result]
727        }
728    }
729    # XXX: add soft-dependencies?
730        return $result
731}
732
733# open_statefile
734# open file to store name of completed targets
735proc open_statefile {args} {
736    global portpath workdir
737
738    if ![file isdirectory $portpath/$workdir] {
739        file mkdir $portpath/$workdir
740    }
741    # flock Portfile
742    set statefile [file join $portpath $workdir .darwinports.state]
743    if {[file exists $statefile] && ![file writable $statefile]} {
744        return -code error "$statefile is not writable - check permission on port directory"
745    }
746    set fd [open $statefile a+]
747    if [catch {flock $fd -exclusive -noblock} result] {
748        if {"$result" == "EAGAIN"} {
749            ui_puts "Waiting for lock on $statefile"
750        } elseif {"$result" == "EOPNOTSUPP"} {
751            # Locking not supported, just return
752            return $fd
753        } else {
754            return -code error "$result obtaining lock on $statefile"
755        }
756    }
757    flock $fd -exclusive
758    return $fd
759}
760
761# check_statefile
762# Check completed state of target $name
763proc check_statefile {name fd} {
764    global portpath workdir
765
766    seek $fd 0
767    while {[gets $fd line] >= 0} {
768        if {[string equal $line $name]} {
769            return 1
770        }
771    }
772    return 0
773}
774
775# write_statefile
776# Set target $name completed in the state file
777proc write_statefile {name fd} {
778    if {[check_statefile $name $fd]} {
779        return 0
780    }
781    seek $fd 0 end
782    puts $fd $name
783    flush $fd
784}
785
786# Traverse the ports collection hierarchy and call procedure func for
787# each directory containing a Portfile
788proc port_traverse {func {dir .}} {
789    set pwd [pwd]
790    if [catch {cd $dir} err] {
791        ui_error $err
792        return
793    }
794    foreach name [readdir .] {
795        if {[string match $name .] || [string match $name ..]} {
796            continue
797        }
798        if [file isdirectory $name] {
799            port_traverse $func $name
800        } else {
801            if [string match $name Portfile] {
802                catch {eval $func {[file join $pwd $dir]}}
803            }
804        }
805    }
806    cd $pwd
807}
808
809
810########### Port Variants ###########
811
812# Each variant which provides a subset of the requested variations
813# will be chosen.  Returns a list of the selected variants.
814proc choose_variants {dlist variations} {
815    upvar $variations upvariations
816
817    set selected [list]
818   
819    foreach obj $dlist {
820                # Enumerate through the provides, tallying the pros and cons.
821                set pros 0
822                set cons 0
823                set ignored 0
824                foreach flavor [$obj get provides] {
825                        if {[info exists upvariations($flavor)]} {
826                                if {$upvariations($flavor) == "+"} {
827                                        incr pros
828                                } elseif {$upvariations($flavor) == "-"} {
829                                        incr cons
830                                }
831                        } else {
832                                incr ignored
833                        }
834                }
835               
836                if {$cons > 0} { continue }
837               
838                if {$pros > 0 && $ignored == 0} {
839                        lappend selected $obj
840                }
841        }
842    return $selected
843}
844
845proc variant_run {this} {
846        set name [$this get name]
847    ui_debug "Executing $name provides [$this get provides]"
848    makeuserproc $name-code "\{[$this get code]\}"
849    if ([catch $name-code result]) {
850                ui_error "Error executing $name: $result"
851                return 1
852        }
853    return 0
854}
855
856proc eval_variants {variations} {
857        global variants
858        set dlist $variants
859        upvar $variations upvariations
860        set chosen [choose_variants $dlist upvariations]
861   
862        # now that we've selected variants, change all provides [a b c] to [a-b-c]
863    # this will eliminate ambiguity between item a, b, and a-b while fulfilling requirments.
864    #foreach obj $dlist {
865    #    $obj set provides [list [join [$obj get provides] -]]
866    #}
867       
868        set newlist [list]
869    foreach variant $chosen {
870        set newlist [dlist_append_dependents $dlist $variant $newlist]
871    }
872
873    dlist_evaluate $newlist generic_get_next
874}
875
876##### DEPSPEC #####
877
878# Object-Oriented Depspecs
879#
880# Each depspec will have its data stored in an array
881# (indexed by field name) and its procedures will be
882# called via the dispatch procedure that is returned
883# from depspec_new.
884#
885# sample usage:
886# set obj [depspec_new]
887# $obj set name "hello"
888#
889
890# Depspec
891#       str name
892#       str provides[]
893#       str requires[]
894#       str uses[]
895
896global depspec_uniqid
897set depspec_uniqid 0
898
899# Depspec class definition.
900global depspec_vtbl
901set depspec_vtbl(test) depspec_test
902set depspec_vtbl(run) depspec_run
903
904# constructor for abstract depspec class
905proc depspec_new {name} {
906        global depspec_uniqid
907        set id [incr depspec_uniqid]
908       
909        # declare the array of data
910        set data dpspc_data_${id}
911        set disp dpspc_disp_${id}
912       
913        global $data 
914        set ${data}(name) $name
915        set ${data}(_vtbl) depspec_vtbl
916       
917        eval "proc $disp {method args} { \n \
918                        global $data \n \
919                        eval return \\\[depspec_dispatch $disp $data \$method \$args\\\] \n \
920                }"
921       
922        return $disp
923}
924
925# is the only proc to get access to the object's data
926# so the get/set routines are defined here.  this lets
927# the virtual members get a real "this" object.
928proc depspec_dispatch {this data method args} {
929        global $data
930        switch $method {
931                get {
932                        set prop [lindex $args 0]
933                        if {[eval info exists ${data}($prop)]} {
934                                eval return $${data}($prop)
935                        } else {
936                                return ""
937                        }
938                }
939                set {
940                        set prop [lindex $args 0]
941                        eval "set ${data}($prop) [lrange $args 1 end]"
942                }
943                has {
944                        set prop [lindex $args 0]
945                        return [info exists ${data}($prop)]
946                }
947                append {
948                        set prop [lindex $args 0]
949                        set vals [join [lrange $args 1 end] " "]
950                        eval "lappend ${data}($prop) $vals"
951                }
952                default {
953                        eval set vtbl $${data}(_vtbl)
954                        global $vtbl
955                        if {[info exists ${vtbl}($method)]} {
956                                eval set function $${vtbl}($method)
957                                eval "return \[$function $this $args\]"
958                        } else {
959                                ui_error "unknown method: $method"
960                        }
961                }
962        }
963        return ""
964}
965
966proc depspec_test {this} {
967        return 0
968}
969
970proc depspec_run {this} {
971        return 0
972}
973
974##### target depspec subclass #####
975
976# Target class definition.
977global target_vtbl
978array set target_vtbl [array get depspec_vtbl]
979set target_vtbl(run) target_run
980
981# constructor for target depspec class
982proc target_new {name} {
983        set obj [depspec_new $name]
984       
985        $obj set _vtbl target_vtbl
986
987        return $obj
988}
989
990##### variant depspec subclass #####
991
992# Variant class definition.
993global variant_vtbl
994array set variant_vtbl [array get depspec_vtbl]
995set variant_vtbl(run) variant_run
996
997# constructor for target depspec class
998proc variant_new {name} {
999        set obj [depspec_new $name]
1000       
1001        $obj set _vtbl variant_vtbl
1002
1003        return $obj
1004}
1005
1006
1007
1008##### bin portfile depspec subclass #####
Note: See TracBrowser for help on using the repository browser.