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

Last change on this file since 960 was 960, checked in by jkh, 16 years ago
  1. rename portname to name (externally) and portversion to version (likewise)
  2. add platforms lines to everything based on current buildability testing on darwin and freebsd.
  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 32.2 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.