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

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

Enhanced options hooks

Allow multiple hooks for each option.
Call hook with option name, action, and list of parameters.

Added portfile class of depspec

First tests registry, then path, then builds.

Cleans before and after building portfile dependencies.

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