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

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

Give useful data

  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 26.9 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} set \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} delete \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} append \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 result 0
629        set procedure [$this get procedure]
630    if {$procedure != ""} {
631                set name [$this get name]
632       
633                if {[$this has init]} {
634                        set result [catch {[$this get init] $name}]
635                }
636                               
637                if {[check_statefile $name $target_state_fd]} {
638                        set result 0
639                        ui_debug "Skipping completed $name"
640                } else {
641                        # Execute pre-run procedure
642                        if {[$this has prerun]} {
643                                set result [catch {[$this get prerun] $name}]
644                        }
645
646                        if {$result == 0} {
647                                foreach pre [$this get pre] {
648                                        ui_debug "Executing $pre"
649                                        set result [catch {$pre $name}]
650                                        if {$result != 0} { break }
651                                }
652                        }
653
654                        if {$result == 0} {
655                                ui_debug "Executing $name"
656                                set result [catch {$procedure $name}]
657                        }
658                       
659                        if {$result == 0} {
660                                foreach post [$this get post] {
661                                        ui_debug "Executing $post"
662                                        set result [catch {$post $name}]
663                                        if {$result != 0} { break }
664                                }
665                        }
666                        # Execute post-run procedure
667                        if {$result == 0 && [$this has postrun]} {
668                                set postrun [$this get postrun]
669                                ui_debug "Executing $postrun"
670                                set result [catch {$postrun $name}]
671                        }
672                }
673                if {$result == 0} {
674                        if {[$this get runtype] != "always"} {
675                                write_statefile $name $target_state_fd
676                        }
677                } else {
678                        ui_error "Target error: $name returned $result"
679                        set result 1
680                }
681               
682    } else {
683                ui_info "Warning: $name does not have a registered procedure"
684                set result 1
685    }
686
687    return $result
688}
689
690proc eval_targets {target} {
691        global targets target_state_fd
692        set dlist $targets
693
694    # Select the subset of targets under $target
695    if {$target != ""} {
696                # XXX munge target. install really means registry, then install
697                # If more than one target ever needs this, make this a generic interface
698                if {$target == "install"} {
699                        set target registry
700                }
701        set matches [depspec_get_matches $dlist provides $target]
702        if {[llength $matches] > 0} {
703                        set dlist [dlist_append_dependents $dlist [lindex $matches 0] [list]]
704                # Special-case 'all'
705        } elseif {$target != "all"} {
706            ui_info "unknown target: $target"
707            return 1
708        }
709    }
710       
711    # Restore the state from a previous run.
712    set target_state_fd [open_statefile]
713   
714    set ret [dlist_evaluate $dlist generic_get_next]
715
716    close $target_state_fd
717        return $ret
718}
719
720# returns the names of dependents of <name> from the <itemlist>
721proc dlist_append_dependents {dlist obj result} {
722
723        # Append the item to the list, avoiding duplicates
724        if {[lsearch $result $obj] == -1} {
725                lappend result $obj
726        }
727       
728    # Recursively append any hard dependencies
729        foreach dep [$obj get requires] {
730                foreach provider [depspec_get_matches $dlist provides $dep] {
731                        set result [dlist_append_dependents $dlist $provider $result]
732        }
733    }
734    # XXX: add soft-dependencies?
735        return $result
736}
737
738# open_statefile
739# open file to store name of completed targets
740proc open_statefile {args} {
741    global portpath workdir
742
743    if ![file isdirectory $portpath/$workdir] {
744        file mkdir $portpath/$workdir
745    }
746    # flock Portfile
747    set statefile [file join $portpath $workdir .darwinports.state]
748    if {[file exists $statefile] && ![file writable $statefile]} {
749        return -code error "$statefile is not writable - check permission on port directory"
750    }
751    set fd [open $statefile a+]
752    if [catch {flock $fd -exclusive -noblock} result] {
753        if {"$result" == "EAGAIN"} {
754            ui_puts "Waiting for lock on $statefile"
755        } elseif {"$result" == "EOPNOTSUPP"} {
756            # Locking not supported, just return
757            return $fd
758        } else {
759            return -code error "$result obtaining lock on $statefile"
760        }
761    }
762    flock $fd -exclusive
763    return $fd
764}
765
766# check_statefile
767# Check completed state of target $name
768proc check_statefile {name fd} {
769    global portpath workdir
770
771    seek $fd 0
772    while {[gets $fd line] >= 0} {
773        if {[string equal $line $name]} {
774            return 1
775        }
776    }
777    return 0
778}
779
780# write_statefile
781# Set target $name completed in the state file
782proc write_statefile {name fd} {
783    if {[check_statefile $name $fd]} {
784        return 0
785    }
786    seek $fd 0 end
787    puts $fd $name
788    flush $fd
789}
790
791# Traverse the ports collection hierarchy and call procedure func for
792# each directory containing a Portfile
793proc port_traverse {func {dir .}} {
794    set pwd [pwd]
795    if [catch {cd $dir} err] {
796        ui_error $err
797        return
798    }
799    foreach name [readdir .] {
800        if {[string match $name .] || [string match $name ..]} {
801            continue
802        }
803        if [file isdirectory $name] {
804            port_traverse $func $name
805        } else {
806            if [string match $name Portfile] {
807                catch {eval $func {[file join $pwd $dir]}}
808            }
809        }
810    }
811    cd $pwd
812}
813
814
815########### Port Variants ###########
816
817# Each variant which provides a subset of the requested variations
818# will be chosen.  Returns a list of the selected variants.
819proc choose_variants {dlist variations} {
820    upvar $variations upvariations
821
822    set selected [list]
823   
824    foreach obj $dlist {
825                # Enumerate through the provides, tallying the pros and cons.
826                set pros 0
827                set cons 0
828                set ignored 0
829                foreach flavor [$obj get provides] {
830                        if {[info exists upvariations($flavor)]} {
831                                if {$upvariations($flavor) == "+"} {
832                                        incr pros
833                                } elseif {$upvariations($flavor) == "-"} {
834                                        incr cons
835                                }
836                        } else {
837                                incr ignored
838                        }
839                }
840               
841                if {$cons > 0} { continue }
842               
843                if {$pros > 0 && $ignored == 0} {
844                        lappend selected $obj
845                }
846        }
847    return $selected
848}
849
850proc variant_run {this} {
851        set name [$this get name]
852    ui_debug "Executing $name provides [$this get provides]"
853    makeuserproc $name-code "\{[$this get code]\}"
854    if ([catch $name-code result]) {
855                ui_error "Error executing $name: $result"
856                return 1
857        }
858    return 0
859}
860
861proc eval_variants {variations} {
862        global variants
863        set dlist $variants
864        upvar $variations upvariations
865        set chosen [choose_variants $dlist upvariations]
866   
867        # now that we've selected variants, change all provides [a b c] to [a-b-c]
868    # this will eliminate ambiguity between item a, b, and a-b while fulfilling requirments.
869    #foreach obj $dlist {
870    #    $obj set provides [list [join [$obj get provides] -]]
871    #}
872       
873        set newlist [list]
874    foreach variant $chosen {
875        set newlist [dlist_append_dependents $dlist $variant $newlist]
876    }
877
878    dlist_evaluate $newlist generic_get_next
879}
880
881##### DEPSPEC #####
882
883# Object-Oriented Depspecs
884#
885# Each depspec will have its data stored in an array
886# (indexed by field name) and its procedures will be
887# called via the dispatch procedure that is returned
888# from depspec_new.
889#
890# sample usage:
891# set obj [depspec_new]
892# $obj set name "hello"
893#
894
895# Depspec
896#       str name
897#       str provides[]
898#       str requires[]
899#       str uses[]
900
901global depspec_uniqid
902set depspec_uniqid 0
903
904# Depspec class definition.
905global depspec_vtbl
906set depspec_vtbl(test) depspec_test
907set depspec_vtbl(run) depspec_run
908
909# constructor for abstract depspec class
910proc depspec_new {name} {
911        global depspec_uniqid
912        set id [incr depspec_uniqid]
913       
914        # declare the array of data
915        set data dpspc_data_${id}
916        set disp dpspc_disp_${id}
917       
918        global $data 
919        set ${data}(name) $name
920        set ${data}(_vtbl) depspec_vtbl
921       
922        eval "proc $disp {method args} { \n \
923                        global $data \n \
924                        eval return \\\[depspec_dispatch $disp $data \$method \$args\\\] \n \
925                }"
926       
927        return $disp
928}
929
930# is the only proc to get access to the object's data
931# so the get/set routines are defined here.  this lets
932# the virtual members get a real "this" object.
933proc depspec_dispatch {this data method args} {
934        global $data
935        switch $method {
936                get {
937                        set prop [lindex $args 0]
938                        if {[eval info exists ${data}($prop)]} {
939                                eval return $${data}($prop)
940                        } else {
941                                return ""
942                        }
943                }
944                set {
945                        set prop [lindex $args 0]
946                        eval "set ${data}($prop) [lrange $args 1 end]"
947                }
948                has {
949                        set prop [lindex $args 0]
950                        return [info exists ${data}($prop)]
951                }
952                append {
953                        set prop [lindex $args 0]
954                        set vals [join [lrange $args 1 end] " "]
955                        eval "lappend ${data}($prop) $vals"
956                }
957                default {
958                        eval set vtbl $${data}(_vtbl)
959                        global $vtbl
960                        if {[info exists ${vtbl}($method)]} {
961                                eval set function $${vtbl}($method)
962                                eval "return \[$function $this $args\]"
963                        } else {
964                                ui_error "unknown method: $method"
965                        }
966                }
967        }
968        return ""
969}
970
971proc depspec_test {this} {
972        return 0
973}
974
975proc depspec_run {this} {
976        return 0
977}
978
979##### target depspec subclass #####
980
981# Target class definition.
982global target_vtbl
983array set target_vtbl [array get depspec_vtbl]
984set target_vtbl(run) target_run
985
986# constructor for target depspec class
987proc target_new {name} {
988        set obj [depspec_new $name]
989       
990        $obj set _vtbl target_vtbl
991
992        return $obj
993}
994
995##### variant depspec subclass #####
996
997# Variant class definition.
998global variant_vtbl
999array set variant_vtbl [array get depspec_vtbl]
1000set variant_vtbl(run) variant_run
1001
1002# constructor for target depspec class
1003proc variant_new {name} {
1004        set obj [depspec_new $name]
1005       
1006        $obj set _vtbl variant_vtbl
1007
1008        return $obj
1009}
1010
1011
1012
1013##### bin portfile depspec subclass #####
Note: See TracBrowser for help on using the repository browser.