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

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

Targets should throw exceptions to indicate failure.
(Custom targets in the portfile shouldn't have to "return 0")

  • 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} ${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 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.