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

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

When appending, verify that variable exists, otherwise, set variable
to supplied value

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