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

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

indenting

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