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

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

optimized exec cat to fcopy in reinplace
ftruncate(2) original file after performing substitutions
added ftruncate(2) command to Pextlib.c

  • 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.