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

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

Make property accessor actual virtual functions.
(Targets will likely want to override some cases of 'set' to do neat things.)

  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 32.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                    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
933set depspec_vtbl(get) depspec_get
934set depspec_vtbl(set) depspec_set
935set depspec_vtbl(has) depspec_has
936set depspec_vtbl(append) depspec_append
937
938# constructor for abstract depspec class
939proc depspec_new {name} {
940    global depspec_uniqid
941    set id [incr depspec_uniqid]
942   
943    # declare the array of data
944    set data dpspc_data_${id}
945    set disp dpspc_disp_${id}
946   
947    global $data 
948    set ${data}(name) $name
949    set ${data}(_vtbl) depspec_vtbl
950   
951    eval "proc $disp {method args} { \n \
952                        global $data \n \
953                        eval return \\\[depspec_dispatch $disp $data \$method \$args\\\] \n \
954                }"
955   
956    return $disp
957}
958
959proc depspec_get {this prop} {
960        set data [$this _data]
961        global $data
962        if {[eval info exists ${data}($prop)]} {
963                eval return $${data}($prop)
964        } else {
965                return ""
966        }
967}
968
969proc depspec_set {this prop args} {
970        set data [$this _data]
971        global $data
972        eval set ${data}($prop) $args
973}
974
975proc depspec_has {this prop} {
976        set data [$this _data]
977        global $data
978        eval return \[info exists ${data}($prop)\]
979}
980
981proc depspec_append {this prop args} {
982        set data [$this _data]
983        global $data
984        set vals [join $args " "]
985        eval lappend ${data}($prop) $vals
986}
987
988# is the only proc to get direct access to the object's data
989# so the _data accessor has to be defined here.  all other
990# methods are looked up in the virtual function table,
991# and are called with {$this $args}.
992proc depspec_dispatch {this data method args} {
993    global $data
994        if {$method == "_data"} { return $data }
995        eval set vtbl $${data}(_vtbl)
996        global $vtbl
997        if {[info exists ${vtbl}($method)]} {
998                eval set function $${vtbl}($method)
999                eval "return \[$function $this $args\]"
1000        } else {
1001                ui_error "unknown method: $method"
1002        }
1003    return ""
1004}
1005
1006proc depspec_test {this} {
1007    return 0
1008}
1009
1010proc depspec_run {this} {
1011    return 0
1012}
1013
1014##### target depspec subclass #####
1015
1016# Target class definition.
1017global target_vtbl
1018array set target_vtbl [array get depspec_vtbl]
1019set target_vtbl(run) target_run
1020
1021# constructor for target depspec class
1022proc target_new {name} {
1023    set obj [depspec_new $name]
1024   
1025    $obj set _vtbl target_vtbl
1026   
1027    return $obj
1028}
1029
1030##### variant depspec subclass #####
1031
1032# Variant class definition.
1033global variant_vtbl
1034array set variant_vtbl [array get depspec_vtbl]
1035set variant_vtbl(run) variant_run
1036
1037# constructor for target depspec class
1038proc variant_new {name} {
1039    set obj [depspec_new $name]
1040   
1041    $obj set _vtbl variant_vtbl
1042   
1043    return $obj
1044}
1045
1046
1047
1048##### portfile depspec subclass #####
1049global portfile_vtbl
1050array set portfile_vtbl [array get depspec_vtbl]
1051set portfile_vtbl(run) portfile_run
1052set portfile_vtbl(test) portfile_test
1053
1054proc portfile_new {name} {
1055    set obj [depspec_new $name]
1056   
1057    $obj set _vtbl portfile_vtbl
1058   
1059    return $obj
1060}
1061
1062# build the specified portfile
1063proc portfile_run {this} {
1064    set portname [$this get name]
1065   
1066    ui_debug "Building $portname"
1067    array set options [list]
1068    array set variations [list]
1069    array set portinfo [dportmatch ^$portname\$]
1070    if {[array size portinfo] == 0} {
1071        ui_error "Dependency $portname not found"
1072        return -1
1073    }
1074    set porturl $portinfo(porturl)
1075   
1076    set worker [dportopen $porturl options variations]
1077    if {[catch {dportexec $worker clean} result] || $result != 0} {
1078        ui_error "Clean of $portname before build failed: $result"
1079        dportclose $worker
1080        return -1
1081    }
1082    if {[catch {dportexec $worker install} result] || $result != 0} {
1083        ui_error "Build of $portname failed: $result"
1084        dportclose $worker
1085        return -1
1086    }
1087    if {[catch {dportexec $worker clean} result] || $result != 0} {
1088        ui_error "Clean of $portname after build failed: $result"
1089    }
1090    dportclose $worker
1091   
1092    return 0
1093}
1094
1095proc portfile_test {this} {
1096    set receipt [registry_exists [$this get name]]
1097    if {$receipt != ""} {
1098        ui_debug "Found Dependency: receipt: $receipt"
1099        return 1
1100    } else {
1101        return 0
1102    }
1103}
1104
1105proc portfile_search_path {depregex search_path} {
1106    set found 0
1107    foreach path $search_path {
1108        if {![file isdirectory $path]} {
1109            continue
1110        }
1111        foreach filename [readdir $path] {
1112            if {[regexp $depregex $filename] == 1} {
1113                ui_debug "Found Dependency: path: $path filename: $filename regex: $depregex"
1114                set found 1
1115                break
1116            }
1117        }
1118    }
1119    return $found
1120}
1121
1122
1123
1124##### lib portfile depspec subclass #####
1125global libportfile_vtbl
1126array set libportfile_vtbl [array get portfile_vtbl]
1127set libportfile_vtbl(test) libportfile_test
1128
1129proc libportfile_new {name match} {
1130    set obj [portfile_new $name]
1131   
1132    $obj set _vtbl libportfile_vtbl
1133    $obj set depregex $match
1134   
1135    return $obj
1136}
1137
1138# XXX - Architecture specific
1139# XXX - Rely on information from internal defines in cctools/dyld:
1140# define DEFAULT_FALLBACK_FRAMEWORK_PATH
1141# /Library/Frameworks:/Library/Frameworks:/Network/Library/Frameworks:/System/Library/Frameworks
1142# define DEFAULT_FALLBACK_LIBRARY_PATH /lib:/usr/local/lib:/lib:/usr/lib
1143# Environment variables DYLD_FRAMEWORK_PATH, DYLD_LIBRARY_PATH,
1144# DYLD_FALLBACK_FRAMEWORK_PATH, and DYLD_FALLBACK_LIBRARY_PATH take precedence
1145
1146proc libportfile_test {this} {
1147    global env prefix
1148   
1149    # Check the registry first
1150    set result [portfile_test $this]
1151    if {$result == 1} {
1152        return $result
1153    } else {
1154        # Not in the registry, check the library path.
1155        set depregex [$this get depregex]
1156       
1157        if {[info exists env(DYLD_FRAMEWORK_PATH)]} {
1158            lappend search_path $env(DYLD_FRAMEWORK_PATH)
1159        } else {
1160            lappend search_path /Library/Frameworks /Network/Library/Frameworks /System/Library/Frameworks
1161        }
1162        if {[info exists env(DYLD_FALLBACK_FRAMEWORK_PATH)]} {
1163            lappend search_path $env(DYLD_FALLBACK_FRAMEWORK_PATH)
1164        }
1165        if {[info exists env(DYLD_LIBRARY_PATH)]} {
1166            lappend search_path $env(DYLD_LIBRARY_PATH)
1167        } else {
1168            lappend search_path /lib /usr/local/lib /lib /usr/lib /op/local/lib /usr/X11R6/lib ${prefix}/lib
1169        }
1170        if {[info exists env(DYLD_FALLBACK_LIBRARY_PATH)]} {
1171            lappend search_path $env(DYLD_LIBRARY_PATH)
1172        }
1173        regsub {\.} $depregex {\.} depregex
1174        set depregex \^$depregex.*\\.dylib\$
1175       
1176        return [portfile_search_path $depregex $search_path]
1177    }
1178}
1179
1180##### bin portfile depspec subclass #####
1181global binportfile_vtbl
1182array set binportfile_vtbl [array get portfile_vtbl]
1183set binportfile_vtbl(test) binportfile_test
1184
1185proc binportfile_new {name match} {
1186    set obj [portfile_new $name]
1187   
1188    $obj set _vtbl binportfile_vtbl
1189    $obj set depregex $match
1190   
1191    return $obj
1192}
1193
1194proc binportfile_test {this} {
1195    global env prefix
1196   
1197    # Check the registry first
1198    set result [portfile_test $this]
1199    if {$result == 1} {
1200        return $result
1201    } else {
1202        # Not in the registry, check the binary path.
1203        set depregex [$this get depregex]
1204       
1205        set search_path [split $env(PATH) :]
1206       
1207        set depregex \^$depregex\$
1208       
1209        return [portfile_search_path $depregex $search_path]
1210    }
1211}
Note: See TracBrowser for help on using the repository browser.