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

Last change on this file since 994 was 994, checked in by jkh, 16 years ago

Remove a debugging puts

  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 32.5 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    # copy from strsed output back into the input
328    if {[catch {fcopy $output $input} error]} {
329        ui_error "reinplace: $error"
330        close $output
331        close $input
332        file delete "$tmpfile"
333        return -code error "reinplace failed"
334    }
335       
336    set eof [file size "$tmpfile"]
337    ftruncate $input $eof 
338
339    close $output
340    close $input
341    file delete "$tmpfile"
342    return
343}
344
345# filefindbypath
346# Provides searching of the standard path for included files
347proc filefindbypath {fname} {
348    global distpath filedir workdir worksrcdir portpath
349
350    if [file readable $fname] {
351        return $fname
352    } elseif [file readable $portpath/$fname] {
353        return $portpath/$fname
354    } elseif [file readable $portpath/$filedir/$fname] {
355        return $portpath/$filedir/$fname
356    } elseif [file readable $distpath/$fname] {
357        return $distpath/$fname
358    } elseif [file readable $portpath/$workdir/$worksrcdir/$fname] {
359        return $portpath/$workdir/$worksrcdir/$fname
360    } elseif [file readable [file join /etc $fname]] {
361        return [file join /etc $fname]
362    }
363    return ""
364}
365
366# include
367# Source a file, looking for it along a standard search path.
368proc include {fname} {
369    set tgt [filefindbypath $fname]
370    if [string length $tgt] {
371        uplevel "source $tgt"
372    } else {
373        return -code error "Unable to find include file $fname"
374    }
375}
376
377# makeuserproc
378# This procedure re-writes the user-defined custom target to include
379# all the globals in its scope.  This is undeniably ugly, but I haven't
380# thought of any other way to do this.
381proc makeuserproc {name body} {
382    regsub -- "^\{(.*)" $body "\{ \n foreach g \[info globals\] \{ \n global \$g \n \} \n \\1 " body
383    eval "proc $name {} $body"
384}
385
386########### External Dependancy Manipulation Procedures ###########
387# register
388# Creates a target in the global target list using the internal dependancy
389#     functions
390# Arguments: <identifier> <mode> <args ...>
391# The following modes are supported:
392#       <identifier> target <procedure to execute> [run type]
393#       <identifier> init <procedure to execute>
394#       <identifier> prerun <procedure to execute>
395#       <identifier> postrun <procedure to execute>
396#       <identifier> provides <list of target names>
397#       <identifier> requires <list of target names>
398#       <identifier> uses <list of target names>
399#       <identifier> deplist <list of deplist names>
400#       <provides> preflight <proc name>
401#       <provides> postflight <proc name>
402proc register {name mode args} {
403    global targets target_uniqid
404   
405    set obj [dlist_get_by_name $targets $name]
406    if {$obj == ""} {
407        set obj [target_new $name]
408        lappend targets $obj
409    }
410   
411    if {$mode == "target"} {
412        set procedure [lindex $args 0]
413        if {[$obj has procedure]} {
414            ui_debug "Warning: target '$name' re-registered (new procedure: '$procedure')"
415        }
416        $obj set procedure $procedure
417       
418        # Set runtype {always,once} if available
419        if {[llength $args] >= 2} {
420            $obj set runtype [lindex $args 1]
421        }
422    } elseif {$mode == "init"} {
423        set init [lindex $args 0]
424        if {[$obj has init]} {
425            ui_debug "Warning: target '$name' re-registered init procedure (new procedure: '$init')"
426        }
427        $obj set init $init
428    } elseif {$mode == "prerun"} {
429        set prerun [lindex $args 0]
430        if {[$obj has prerun]} {
431            ui_debug "Warning: target '$name' re-registered pre-run procedure (new procedure: '$prerun')"
432        }
433        $obj prerun $prerun
434    } elseif {$mode == "postrun"} {
435        set postrun [lindex $args 0]
436        if {[$obj has postrun]} {
437            ui_debug "Warning: target '$name' re-registered post-run procedure (new procedure: '$postrun')"
438        }
439        $obj set postrun $postrun
440    } elseif {$mode == "requires" || $mode == "uses" || $mode == "provides"} {
441        $obj append $mode $args
442       
443        if {$mode == "provides"} {
444            # If it's a provides, register the pre-/post- hooks for use in Portfile.
445            # Portfile syntax: pre-fetch { puts "hello world" }
446            # User-code exceptions are caught and returned as a result of the target.
447            # Thus if the user code breaks, dependent targets will not execute.
448            foreach target $args {
449                if {[info commands $target] != ""} {
450                    ui_error "$name attempted to register provide \'$target\' which is a pre-existing procedure. Ignoring register."
451                    continue;
452                }
453                set ident [lindex [depspec_get_matches $targets provides $args] 0]
454                set origproc [$ident get procedure]
455                set ident [$ident get name]
456                eval "proc $target {args} \{ \n\
457                                        global target_uniqid \n\
458                                        set id \[incr target_uniqid\] \n\
459                    register $ident target proc-$target\$id \n\
460                    eval \"proc proc-$target\$id \{name\} \{ \n\
461                        if \\\[catch userproc-$target\$id result\\\] \{ \n\
462                                                        ui_info \\\$result \n\
463                                                        return 1 \n\
464                                                \} else \{ \n\
465                                                        return 0 \n\
466                                                \} \n\
467                    \}\" \n\
468                    eval \"proc do-$target \{\} \{ $origproc $target\}\" \n\
469                    makeuserproc userproc-$target\$id \$args \}"
470                eval "proc pre-$target {args} \{ \n\
471                                        global target_uniqid \n\
472                                        set id \[incr target_uniqid\] \n\
473                    register $target preflight pre-$target\$id \n\
474                    eval \"proc pre-$target\$id \{name\} \{ \n\
475                        if \\\[catch userproc-pre-$target\$id result\\\] \{ \n\
476                                                        ui_info \\\$result \n\
477                                                        return 1 \n\
478                                                \} else \{ \n\
479                                                        return 0 \n\
480                                                \} \n\
481                    \}\" \n\
482                    makeuserproc userproc-pre-$target\$id \$args \}"
483                eval "proc post-$target {args} \{ \n\
484                                        global target_uniqid \n\
485                                        set id \[incr target_uniqid\] \n\
486                    register $target postflight post-$target\$id \n\
487                    eval \"proc post-$target\$id \{name\} \{ \n\
488                        if \\\[catch userproc-post-$target\$id result\\\] \{ \n\
489                                                        ui_info \\\$result \n\
490                                                        return 1 \n\
491                                                \} else \{ \n\
492                                                        return 0 \n\
493                                                \} \n\
494                    \}\" \n\
495                    makeuserproc userproc-post-$target\$id \$args \}"
496            }
497        }
498       
499    } elseif {$mode == "deplist"} {
500        $obj append $mode $args
501       
502    } elseif {$mode == "preflight"} {
503        # Find target which provides the specified name, and add a preflight.
504        # XXX: this only returns the first match, is this what we want?
505        set obj [lindex [depspec_get_matches $targets provides $name] 0]
506        $obj append pre $args
507       
508    } elseif {$mode == "postflight"} {
509        # Find target which provides the specified name, and add a preflight.
510        # XXX: this only returns the first match, is this what we want?
511        set obj [lindex [depspec_get_matches $targets provides $name] 0]
512        $obj append post $args
513    }
514}
515
516
517# unregister
518# Unregisters a target in the global target list
519# Arguments: target <target name>
520proc unregister {mode target} {
521}
522
523########### Internal Dependancy Manipulation Procedures ###########
524
525# returns a depspec by name
526proc dlist_get_by_name {dlist name} {
527    set result ""
528    foreach d $dlist {
529        if {[$d get name] == $name} {
530            set result $d
531            break
532        }
533    }
534    return $result
535}
536
537# returns a list of depspecs that contain the given name in the given key
538proc depspec_get_matches {dlist key value} {
539    set result [list]
540    foreach d $dlist {
541        foreach val [$d get $key] {
542            if {$val == $value} {
543                lappend result $d
544            }
545        }
546    }
547    return $result
548}
549
550# Count the unmet dependencies in the dlist based on the statusdict
551proc dlist_count_unmet {dlist statusdict names} {
552    upvar $statusdict upstatusdict
553    set unmet 0
554    foreach name $names {
555        # Service was provided, check next.
556        if {[info exists upstatusdict($name)] && $upstatusdict($name) == 1} {
557            continue
558        } else {
559            incr unmet
560        }
561    }
562    return $unmet
563}
564
565# Returns true if any of the dependencies are pending in the dlist
566proc dlist_has_pending {dlist uses} {
567    foreach name $uses {
568        if {[llength [depspec_get_matches $dlist provides $name]] > 0} {
569            return 1
570        }
571    }
572    return 0
573}
574
575# Get the name of the next eligible item from the dependency list
576proc generic_get_next {dlist statusdict} {
577    set nextitem ""
578    # arbitrary large number ~ INT_MAX
579    set minfailed 2000000000
580    upvar $statusdict upstatusdict
581   
582    foreach obj $dlist {               
583        # skip if unsatisfied hard dependencies
584        if {[dlist_count_unmet $dlist upstatusdict [$obj get requires]]} { continue }
585       
586        # favor item with fewest unment soft dependencies
587        set unmet [dlist_count_unmet $dlist upstatusdict [$obj get uses]]
588       
589        # delay items with unmet soft dependencies that can be filled
590        if {$unmet > 0 && [dlist_has_pending $dlist [$obj get uses]]} { continue }
591       
592        if {$unmet >= $minfailed} {
593            # not better than our last pick
594            continue
595        } else {
596            # better than our last pick
597            set minfailed $unmet
598            set nextitem $obj
599        }
600    }
601    return $nextitem
602}
603
604
605# Evaluate the list of depspecs, running each as it becomes eligible.
606# dlist is a collection of depspec objects to be run
607# get_next_proc is used to determine the best item to run
608proc dlist_evaluate {dlist get_next_proc} {
609    global portname
610       
611    # status - keys will be node names, values will be {-1, 0, 1}.
612    array set statusdict [list]
613       
614    # XXX: Do we want to evaluate this dynamically instead of statically?
615    foreach obj $dlist {
616        if {[$obj test] == 1} {
617            foreach name [$obj get provides] {
618                set statusdict($name) 1
619            }
620            ldelete dlist $obj
621        }
622    }
623   
624    # loop for as long as there are nodes in the dlist.
625    while (1) {
626        set obj [$get_next_proc $dlist statusdict]
627       
628        if {$obj == ""} { 
629            break
630        } else {
631            set result [$obj run]
632            # depspec->run returns an error code, so 0 == success.
633            # translate this to the statusdict notation where 1 == success.
634            foreach name [$obj get provides] {
635                set statusdict($name) [expr $result == 0]
636            }
637           
638            # Delete the item from the waiting list.
639            ldelete dlist $obj
640        }
641    }
642   
643    if {[llength $dlist] > 0} {
644        # somebody broke!
645        ui_info "Warning: the following items did not execute (for $portname): "
646        foreach obj $dlist {
647            ui_info "[$obj get name] " -nonewline
648        }
649        ui_info ""
650        return 1
651    }
652    return 0
653}
654
655proc target_run {this} {
656    global target_state_fd portname
657    set result 0
658    set procedure [$this get procedure]
659    if {$procedure != ""} {
660        set name [$this get name]
661       
662        if {[$this has init]} {
663            set result [catch {[$this get init] $name} errstr]
664        }
665       
666        if {[check_statefile $name $target_state_fd]} {
667            set result 0
668            ui_debug "Skipping completed $name ($portname)"
669        } else {
670            # Execute pre-run procedure
671            if {[$this has prerun]} {
672                set result [catch {[$this get prerun] $name} errstr]
673            }
674           
675            if {$result == 0} {
676                foreach pre [$this get pre] {
677                    ui_debug "Executing $pre"
678                    set result [catch {$pre $name} errstr]
679                    if {$result != 0} { break }
680                }
681            }
682           
683            if {$result == 0} {
684                ui_debug "Executing $name ($portname)"
685                set result [catch {$procedure $name} errstr]
686            }
687           
688            if {$result == 0} {
689                foreach post [$this get post] {
690                    ui_debug "Executing $post"
691                    set result [catch {$post $name} errstr]
692                    if {$result != 0} { break }
693                }
694            }
695            # Execute post-run procedure
696            if {[$this has postrun] && $result == 0} {
697                set postrun [$this get postrun]
698                ui_debug "Executing $postrun"
699                set result [catch {$postrun $name} errstr]
700            }
701        }
702        if {$result == 0} {
703            if {[$this get runtype] != "always"} {
704                write_statefile $name $target_state_fd
705            }
706        } else {
707            ui_error "Target error: $name returned: $errstr"
708            set result 1
709        }
710       
711    } else {
712        ui_info "Warning: $name does not have a registered procedure"
713        set result 1
714    }
715   
716    return $result
717}
718
719proc eval_targets {target} {
720    global targets target_state_fd
721    set dlist $targets
722   
723    # Select the subset of targets under $target
724    if {$target != ""} {
725        # XXX munge target. install really means registry, then install
726        # If more than one target ever needs this, make this a generic interface
727        if {$target == "install"} {
728            set target registry
729        }
730        set matches [depspec_get_matches $dlist provides $target]
731        if {[llength $matches] > 0} {
732            set dlist [dlist_append_dependents $dlist [lindex $matches 0] [list]]
733            # Special-case 'all'
734        } elseif {$target != "all"} {
735            ui_info "unknown target: $target"
736            return 1
737        }
738    }
739   
740    # Restore the state from a previous run.
741    set target_state_fd [open_statefile]
742   
743    set ret [dlist_evaluate $dlist generic_get_next]
744   
745    close $target_state_fd
746    return $ret
747}
748
749# returns the names of dependents of <name> from the <itemlist>
750proc dlist_append_dependents {dlist obj result} {
751   
752    # Append the item to the list, avoiding duplicates
753    if {[lsearch $result $obj] == -1} {
754        lappend result $obj
755    }
756   
757    # Recursively append any hard dependencies
758    foreach dep [$obj get requires] {
759        foreach provider [depspec_get_matches $dlist provides $dep] {
760            set result [dlist_append_dependents $dlist $provider $result]
761        }
762    }
763    # XXX: add soft-dependencies?
764    return $result
765}
766
767# open_statefile
768# open file to store name of completed targets
769proc open_statefile {args} {
770    global portpath workdir
771   
772    if ![file isdirectory $portpath/$workdir] {
773        file mkdir $portpath/$workdir
774    }
775    # flock Portfile
776    set statefile [file join $portpath $workdir .darwinports.state]
777    if {[file exists $statefile] && ![file writable $statefile]} {
778        return -code error "$statefile is not writable - check permission on port directory"
779    }
780    set fd [open $statefile a+]
781    if [catch {flock $fd -exclusive -noblock} result] {
782        if {"$result" == "EAGAIN"} {
783            ui_puts "Waiting for lock on $statefile"
784        } elseif {"$result" == "EOPNOTSUPP"} {
785            # Locking not supported, just return
786            return $fd
787        } else {
788            return -code error "$result obtaining lock on $statefile"
789        }
790    }
791    flock $fd -exclusive
792    return $fd
793}
794
795# check_statefile
796# Check completed state of target $name
797proc check_statefile {name fd} {
798    global portpath workdir
799   
800    seek $fd 0
801    while {[gets $fd line] >= 0} {
802        if {[string equal $line $name]} {
803            return 1
804        }
805    }
806    return 0
807}
808
809# write_statefile
810# Set target $name completed in the state file
811proc write_statefile {name fd} {
812    if {[check_statefile $name $fd]} {
813        return 0
814    }
815    seek $fd 0 end
816    puts $fd $name
817    flush $fd
818}
819
820# Traverse the ports collection hierarchy and call procedure func for
821# each directory containing a Portfile
822proc port_traverse {func {dir .}} {
823    set pwd [pwd]
824    if [catch {cd $dir} err] {
825        ui_error $err
826        return
827    }
828    foreach name [readdir .] {
829        if {[string match $name .] || [string match $name ..]} {
830            continue
831        }
832        if [file isdirectory $name] {
833            port_traverse $func $name
834        } else {
835            if [string match $name Portfile] {
836                catch {eval $func {[file join $pwd $dir]}}
837            }
838        }
839    }
840    cd $pwd
841}
842
843
844########### Port Variants ###########
845
846# Each variant which provides a subset of the requested variations
847# will be chosen.  Returns a list of the selected variants.
848proc choose_variants {dlist variations} {
849    upvar $variations upvariations
850   
851    set selected [list]
852   
853    foreach obj $dlist {
854        # Enumerate through the provides, tallying the pros and cons.
855        set pros 0
856        set cons 0
857        set ignored 0
858        foreach flavor [$obj get provides] {
859            if {[info exists upvariations($flavor)]} {
860                if {$upvariations($flavor) == "+"} {
861                    incr pros
862                } elseif {$upvariations($flavor) == "-"} {
863                    incr cons
864                }
865            } else {
866                incr ignored
867            }
868        }
869       
870        if {$cons > 0} { continue }
871       
872        if {$pros > 0 && $ignored == 0} {
873            lappend selected $obj
874        }
875    }
876    return $selected
877}
878
879proc variant_run {this} {
880    set name [$this get name]
881    ui_debug "Executing $name provides [$this get provides]"
882    makeuserproc $name-code "\{[$this get code]\}"
883    if ([catch $name-code result]) {
884        ui_error "Error executing $name: $result"
885        return 1
886    }
887    return 0
888}
889
890proc eval_variants {variations} {
891    global variants
892    set dlist $variants
893    upvar $variations upvariations
894    set chosen [choose_variants $dlist upvariations]
895   
896    # now that we've selected variants, change all provides [a b c] to [a-b-c]
897    # this will eliminate ambiguity between item a, b, and a-b while fulfilling requirments.
898    #foreach obj $dlist {
899    #    $obj set provides [list [join [$obj get provides] -]]
900    #}
901   
902    set newlist [list]
903    foreach variant $chosen {
904        set newlist [dlist_append_dependents $dlist $variant $newlist]
905    }
906   
907    dlist_evaluate $newlist generic_get_next
908}
909
910##### DEPSPEC #####
911
912# Object-Oriented Depspecs
913#
914# Each depspec will have its data stored in an array
915# (indexed by field name) and its procedures will be
916# called via the dispatch procedure that is returned
917# from depspec_new.
918#
919# sample usage:
920# set obj [depspec_new]
921# $obj set name "hello"
922#
923
924# Depspec
925#       str name
926#       str provides[]
927#       str requires[]
928#       str uses[]
929
930global depspec_uniqid
931set depspec_uniqid 0
932
933# Depspec class definition.
934global depspec_vtbl
935set depspec_vtbl(test) depspec_test
936set depspec_vtbl(run) depspec_run
937set depspec_vtbl(get) depspec_get
938set depspec_vtbl(set) depspec_set
939set depspec_vtbl(has) depspec_has
940set depspec_vtbl(append) depspec_append
941
942# constructor for abstract depspec class
943proc depspec_new {name} {
944    global depspec_uniqid
945    set id [incr depspec_uniqid]
946   
947    # declare the array of data
948    set data dpspc_data_${id}
949    set disp dpspc_disp_${id}
950   
951    global $data 
952    set ${data}(name) $name
953    set ${data}(_vtbl) depspec_vtbl
954   
955    eval "proc $disp {method args} { \n \
956                        global $data \n \
957                        eval return \\\[depspec_dispatch $disp $data \$method \$args\\\] \n \
958                }"
959   
960    return $disp
961}
962
963proc depspec_get {this prop} {
964        set data [$this _data]
965        global $data
966        if {[eval info exists ${data}($prop)]} {
967                eval return $${data}($prop)
968        } else {
969                return ""
970        }
971}
972
973proc depspec_set {this prop args} {
974        set data [$this _data]
975        global $data
976        eval set ${data}($prop) $args
977}
978
979proc depspec_has {this prop} {
980        set data [$this _data]
981        global $data
982        eval return \[info exists ${data}($prop)\]
983}
984
985proc depspec_append {this prop args} {
986        set data [$this _data]
987        global $data
988        set vals [join $args " "]
989        eval lappend ${data}($prop) $vals
990}
991
992# is the only proc to get direct access to the object's data
993# so the _data accessor has to be defined here.  all other
994# methods are looked up in the virtual function table,
995# and are called with {$this $args}.
996proc depspec_dispatch {this data method args} {
997    global $data
998        if {$method == "_data"} { return $data }
999        eval set vtbl $${data}(_vtbl)
1000        global $vtbl
1001        if {[info exists ${vtbl}($method)]} {
1002                eval set function $${vtbl}($method)
1003                eval "return \[$function $this $args\]"
1004        } else {
1005                ui_error "unknown method: $method"
1006        }
1007    return ""
1008}
1009
1010proc depspec_test {this} {
1011    return 0
1012}
1013
1014proc depspec_run {this} {
1015    return 0
1016}
1017
1018##### target depspec subclass #####
1019
1020# Target class definition.
1021global target_vtbl
1022array set target_vtbl [array get depspec_vtbl]
1023set target_vtbl(run) target_run
1024
1025# constructor for target depspec class
1026proc target_new {name} {
1027    set obj [depspec_new $name]
1028   
1029    $obj set _vtbl target_vtbl
1030   
1031    return $obj
1032}
1033
1034##### variant depspec subclass #####
1035
1036# Variant class definition.
1037global variant_vtbl
1038array set variant_vtbl [array get depspec_vtbl]
1039set variant_vtbl(run) variant_run
1040
1041# constructor for target depspec class
1042proc variant_new {name} {
1043    set obj [depspec_new $name]
1044   
1045    $obj set _vtbl variant_vtbl
1046   
1047    return $obj
1048}
1049
1050
1051
1052##### portfile depspec subclass #####
1053global portfile_vtbl
1054array set portfile_vtbl [array get depspec_vtbl]
1055set portfile_vtbl(run) portfile_run
1056set portfile_vtbl(test) portfile_test
1057
1058proc portfile_new {name} {
1059    set obj [depspec_new $name]
1060   
1061    $obj set _vtbl portfile_vtbl
1062   
1063    return $obj
1064}
1065
1066# build the specified portfile
1067proc portfile_run {this} {
1068    set portname [$this get name]
1069   
1070    ui_debug "Building $portname"
1071    array set options [list]
1072    array set variations [list]
1073    array set portinfo [dportmatch ^$portname\$]
1074    if {[array size portinfo] == 0} {
1075        ui_error "Dependency $portname not found"
1076        return -1
1077    }
1078    set porturl $portinfo(porturl)
1079   
1080    set worker [dportopen $porturl options variations]
1081    if {[catch {dportexec $worker clean} result] || $result != 0} {
1082        ui_error "Clean of $portname before build failed: $result"
1083        dportclose $worker
1084        return -1
1085    }
1086    if {[catch {dportexec $worker install} result] || $result != 0} {
1087        ui_error "Build of $portname failed: $result"
1088        dportclose $worker
1089        return -1
1090    }
1091    if {[catch {dportexec $worker clean} result] || $result != 0} {
1092        ui_error "Clean of $portname after build failed: $result"
1093    }
1094    dportclose $worker
1095   
1096    return 0
1097}
1098
1099proc portfile_test {this} {
1100    set receipt [registry_exists [$this get name]]
1101    if {$receipt != ""} {
1102        ui_debug "Found Dependency: receipt: $receipt"
1103        return 1
1104    } else {
1105        return 0
1106    }
1107}
1108
1109proc portfile_search_path {depregex search_path} {
1110    set found 0
1111    foreach path $search_path {
1112        if {![file isdirectory $path]} {
1113            continue
1114        }
1115        foreach filename [readdir $path] {
1116            if {[regexp $depregex $filename] == 1} {
1117                ui_debug "Found Dependency: path: $path filename: $filename regex: $depregex"
1118                set found 1
1119                break
1120            }
1121        }
1122    }
1123    return $found
1124}
1125
1126
1127
1128##### lib portfile depspec subclass #####
1129global libportfile_vtbl
1130array set libportfile_vtbl [array get portfile_vtbl]
1131set libportfile_vtbl(test) libportfile_test
1132
1133proc libportfile_new {name match} {
1134    set obj [portfile_new $name]
1135   
1136    $obj set _vtbl libportfile_vtbl
1137    $obj set depregex $match
1138   
1139    return $obj
1140}
1141
1142# XXX - Architecture specific
1143# XXX - Rely on information from internal defines in cctools/dyld:
1144# define DEFAULT_FALLBACK_FRAMEWORK_PATH
1145# /Library/Frameworks:/Library/Frameworks:/Network/Library/Frameworks:/System/Library/Frameworks
1146# define DEFAULT_FALLBACK_LIBRARY_PATH /lib:/usr/local/lib:/lib:/usr/lib
1147# Environment variables DYLD_FRAMEWORK_PATH, DYLD_LIBRARY_PATH,
1148# DYLD_FALLBACK_FRAMEWORK_PATH, and DYLD_FALLBACK_LIBRARY_PATH take precedence
1149
1150proc libportfile_test {this} {
1151    global env prefix
1152   
1153    # Check the registry first
1154    set result [portfile_test $this]
1155    if {$result == 1} {
1156        return $result
1157    } else {
1158        # Not in the registry, check the library path.
1159        set depregex [$this get depregex]
1160       
1161        if {[info exists env(DYLD_FRAMEWORK_PATH)]} {
1162            lappend search_path $env(DYLD_FRAMEWORK_PATH)
1163        } else {
1164            lappend search_path /Library/Frameworks /Network/Library/Frameworks /System/Library/Frameworks
1165        }
1166        if {[info exists env(DYLD_FALLBACK_FRAMEWORK_PATH)]} {
1167            lappend search_path $env(DYLD_FALLBACK_FRAMEWORK_PATH)
1168        }
1169        if {[info exists env(DYLD_LIBRARY_PATH)]} {
1170            lappend search_path $env(DYLD_LIBRARY_PATH)
1171        } else {
1172            lappend search_path /lib /usr/local/lib /lib /usr/lib /op/local/lib /usr/X11R6/lib ${prefix}/lib
1173        }
1174        if {[info exists env(DYLD_FALLBACK_LIBRARY_PATH)]} {
1175            lappend search_path $env(DYLD_LIBRARY_PATH)
1176        }
1177        regsub {\.} $depregex {\.} depregex
1178        set depregex \^$depregex.*\\.dylib\$
1179       
1180        return [portfile_search_path $depregex $search_path]
1181    }
1182}
1183
1184##### bin portfile depspec subclass #####
1185global binportfile_vtbl
1186array set binportfile_vtbl [array get portfile_vtbl]
1187set binportfile_vtbl(test) binportfile_test
1188
1189proc binportfile_new {name match} {
1190    set obj [portfile_new $name]
1191   
1192    $obj set _vtbl binportfile_vtbl
1193    $obj set depregex $match
1194   
1195    return $obj
1196}
1197
1198proc binportfile_test {this} {
1199    global env prefix
1200   
1201    # Check the registry first
1202    set result [portfile_test $this]
1203    if {$result == 1} {
1204        return $result
1205    } else {
1206        # Not in the registry, check the binary path.
1207        set depregex [$this get depregex]
1208       
1209        set search_path [split $env(PATH) :]
1210       
1211        set depregex \^$depregex\$
1212       
1213        return [portfile_search_path $depregex $search_path]
1214    }
1215}
Note: See TracBrowser for help on using the repository browser.