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

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

Fix problem with dots in variable names
Reported by: yeled

  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 31.6 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                    set $option \[concat \$\{$option\} \$args\] \n\
85                         if \{\[info exists option_procs($option)\]\} \{ \n\
86                                foreach p \$option_procs($option) \{ \n\
87                                        eval \"\$p $option append \$args\" \n\
88                                \} \n\
89                         \} \n\
90                \} \n\
91        \}"
92    }
93}
94
95proc options_export {args} {
96    foreach option $args {
97        eval "proc options::${option} \{args\} \{ \n\
98            global ${option} PortInfo \n\
99            if \{\[info exists ${option}\]\} \{ \n\
100                set PortInfo(${option}) \$${option} \n\
101            \} else \{ \n\
102                unset PortInfo(${option}) \n\
103            \} \n\
104        \}"
105        option_proc ${option} options::${option}
106    }
107}
108
109proc option_proc {option args} {
110        global option_procs
111        eval "lappend option_procs($option) $args"
112}
113
114# commands
115# Accepts a list of arguments, of which several options are created
116# and used to form a standard set of command options.
117proc commands {args} {
118    foreach option $args {
119        options use_${option} ${option}.dir ${option}.pre_args ${option}.args ${option}.post_args ${option}.env ${option}.type ${option}.cmd
120    }
121}
122
123# command
124# Given a command name, command assembled a string
125# composed of the command options.
126proc command {command} {
127    global ${command}.dir ${command}.pre_args ${command}.args ${command}.post_args ${command}.env ${command}.type ${command}.cmd
128
129    set cmdstring ""
130    if [info exists ${command}.dir] {
131        set cmdstring "cd [set ${command}.dir] &&"
132    }
133
134    if [info exists ${command}.env] {
135        foreach string [set ${command}.env] {
136                set cmdstring "$cmdstring $string"
137        }
138    }
139
140    if [info exists ${command}.cmd] {
141        foreach string [set ${command}.cmd] {
142                set cmdstring "$cmdstring $string"
143        }
144    } else {
145        set cmdstring "$cmdstring ${command}"
146    }
147    foreach var "${command}.pre_args ${command}.args ${command}.post_args" {
148        if [info exists $var] {
149        foreach string [set ${var}] {
150                set cmdstring "$cmdstring $string"
151        }
152        }
153    }
154    ui_debug "Assembled command: '$cmdstring'"
155    return $cmdstring
156}
157
158# default
159# Sets a variable to the supplied default if it does not exist,
160# and adds a variable trace. The variable traces allows for delayed
161# variable and command expansion in the variable's default value.
162proc default {option val} {
163    global $option option_defaults
164        if {[info exists option_defaults($option)]} {
165                ui_debug "Re-registering default for $option"
166        } else {
167                # If option is already set and we did not set it
168                # do not reset the value
169                if {[info exists $option]} {
170                        return
171                }
172        }
173        set option_defaults($option) $val
174        set $option $val
175        trace variable $option rwu default_check
176}
177
178# default_check
179# trace handler to provide delayed variable & command expansion
180# for default variable values
181proc default_check {optionName index op} {
182        global option_defaults $optionName
183        switch $op {
184                w {
185                        unset option_defaults($optionName)
186                        trace vdelete $optionName rwu default_check
187                        return
188                }
189                r {
190                        upvar $optionName option
191                        uplevel #0 set $optionName $option_defaults($optionName)
192                        return
193                }
194                u {
195                        unset option_defaults($optionName)
196                        trace vdelete $optionName rwu default_check
197                        return
198                }
199        }
200}
201
202# variant <provides> [<provides> ...] [requires <requires> [<requires>]]
203# Portfile level procedure to provide support for declaring variants
204proc variant {args} {
205    global variants PortInfo
206    upvar $args upargs
207   
208    set len [llength $args]
209    set code [lindex $args end]
210    set args [lrange $args 0 [expr $len - 2]]
211   
212    set provides [list]
213    set requires [list]
214   
215    # halfway through the list we'll hit 'requires' which tells us
216    # to switch into processing required flavors/depspecs.
217    set after_requires 0
218    foreach arg $args {
219        if ([string equal $arg requires]) { 
220            set after_requires 1
221            continue
222        }
223        if ($after_requires) {
224            lappend requires $arg
225        } else {
226            lappend provides $arg
227        }
228    }
229    set name "variant-[join $provides -]"
230    set obj [variant_new $name]
231    $obj append provides $provides
232    $obj append requires $requires
233    $obj set code $code
234        lappend variants $obj
235
236    # Export provided variant to PortInfo
237    lappend PortInfo(variants) $provides
238}
239
240# variant_isset name
241# Returns 1 if variant name selected, otherwise 0
242proc variant_isset {name} {
243    global variations
244
245    if {[info exists variations($name)] && $variations($name) == "+"} {
246        return 1
247    }
248    return 0
249}
250
251# variant_set name
252# Sets variant to run for current portfile
253proc variant_set {name} {
254    global variations
255
256    set variations($name) +
257}
258
259# variant_unset name
260# Clear variant for current portfile
261proc variant_unset {name} {
262    global variations
263
264    set variations($name) -
265}
266
267########### Misc Utility Functions ###########
268
269# tbool (testbool)
270# If the variable exists in the calling procedure's namespace
271# and is set to "yes", return 1. Otherwise, return 0
272proc tbool {key} {
273    upvar $key $key
274    if {[info exists $key]} {
275        if {[string equal -nocase [set $key] "yes"]} {
276            return 1
277        }
278    }
279    return 0
280}
281
282# ldelete
283# Deletes a value from the supplied list
284proc ldelete {list value} {
285    upvar $list uplist
286    set ix [lsearch -exact $uplist $value]
287    if {$ix >= 0} {
288        set uplist [lreplace $uplist $ix $ix]
289    }
290}
291
292# reinplace
293# Provides "sed in place" functionality
294proc reinplace {oddpattern file}  {
295    set backpattern [strsed $oddpattern {g/\//\\\\\//}]
296    set pattern [strsed $backpattern {g/\|/\//}]
297
298    if {[catch {set input [open "$file" RDWR]} error]} {
299        ui_error "reinplace: $error"
300        return -code error "reinplace failed"
301    }
302
303    if {[catch {set result [mkstemp "/tmp/[file tail $file].sed.XXXXXXXX"]} error]} {
304        ui_error "reinplace: $error"
305        close $input
306        return -code error "reinplace failed"
307    }
308
309    set output [lindex $result 0]
310    set tmpfile [lindex $result 1]
311
312    if {[catch {exec sed $pattern <@$input >@$output} error]} {
313        ui_error "reinplace: $error"
314        close $output
315        close $input
316        file delete "$tmpfile"
317        return -code error "reinplace failed"
318    }
319
320    seek $output 0
321    seek $input 0
322
323    if {[catch {exec cat <@$output >@$input 2>/dev/null} error]} {
324        ui_error "reinplace: $error"
325        close $output
326        close $input
327        file delete "$tmpfile"
328        return -code error "reinplace failed"
329    }
330
331    close $output
332    close $input
333    file delete "$tmpfile"
334    return
335}
336
337# filefindbypath
338# Provides searching of the standard path for included files
339proc filefindbypath {fname} {
340    global distpath filedir workdir worksrcdir portpath
341
342    if [file readable $fname] {
343        return $fname
344    } elseif [file readable $portpath/$fname] {
345        return $portpath/$fname
346    } elseif [file readable $portpath/$filedir/$fname] {
347        return $portpath/$filedir/$fname
348    } elseif [file readable $distpath/$fname] {
349        return $distpath/$fname
350    } elseif [file readable $portpath/$workdir/$worksrcdir/$fname] {
351        return $portpath/$workdir/$worksrcdir/$fname
352    } elseif [file readable [file join /etc $fname]] {
353        return [file join /etc $fname]
354    }
355    return ""
356}
357
358# include
359# Source a file, looking for it along a standard search path.
360proc include {fname} {
361    set tgt [filefindbypath $fname]
362    if [string length $tgt] {
363        uplevel "source $tgt"
364    } else {
365        return -code error "Unable to find include file $fname"
366    }
367}
368
369# makeuserproc
370# This procedure re-writes the user-defined custom target to include
371# all the globals in its scope.  This is undeniably ugly, but I haven't
372# thought of any other way to do this.
373proc makeuserproc {name body} {
374    regsub -- "^\{(.*)" $body "\{ \n foreach g \[info globals\] \{ \n global \$g \n \} \n \\1 " body
375    eval "proc $name {} $body"
376}
377
378########### External Dependancy Manipulation Procedures ###########
379# register
380# Creates a target in the global target list using the internal dependancy
381#     functions
382# Arguments: <identifier> <mode> <args ...>
383# The following modes are supported:
384#       <identifier> target <procedure to execute> [run type]
385#       <identifier> init <procedure to execute>
386#       <identifier> prerun <procedure to execute>
387#       <identifier> postrun <procedure to execute>
388#       <identifier> provides <list of target names>
389#       <identifier> requires <list of target names>
390#       <identifier> uses <list of target names>
391#       <identifier> deplist <list of deplist names>
392#       <provides> preflight <proc name>
393#       <provides> postflight <proc name>
394proc register {name mode args} {
395    global targets target_uniqid
396   
397        set obj [dlist_get_by_name $targets $name]
398        if {$obj == ""} {
399                set obj [target_new $name]
400                lappend targets $obj
401        }
402
403    if {$mode == "target"} {
404        set procedure [lindex $args 0]
405        if {[$obj has procedure]} {
406            ui_debug "Warning: target '$name' re-registered (new procedure: '$procedure')"
407        }
408        $obj set procedure $procedure
409               
410                # Set runtype {always,once} if available
411                if {[llength $args] >= 2} {
412                        $obj set runtype [lindex $args 1]
413                }
414    } elseif {$mode == "init"} {
415                set init [lindex $args 0]
416                if {[$obj has init]} {
417                        ui_debug "Warning: target '$name' re-registered init procedure (new procedure: '$init')"
418                }
419                $obj set init $init
420    } elseif {$mode == "prerun"} {
421                set prerun [lindex $args 0]
422                if {[$obj has prerun]} {
423                        ui_debug "Warning: target '$name' re-registered pre-run procedure (new procedure: '$prerun')"
424                }
425                $obj prerun $prerun
426    } elseif {$mode == "postrun"} {
427                set postrun [lindex $args 0]
428                if {[$obj has postrun]} {
429                        ui_debug "Warning: target '$name' re-registered post-run procedure (new procedure: '$postrun')"
430                }
431                $obj set postrun $postrun
432    } elseif {$mode == "requires" || $mode == "uses" || $mode == "provides"} {
433                $obj append $mode $args
434       
435        if {$mode == "provides"} {
436            # If it's a provides, register the pre-/post- hooks for use in Portfile.
437            # Portfile syntax: pre-fetch { puts "hello world" }
438            # User-code exceptions are caught and returned as a result of the target.
439            # Thus if the user code breaks, dependent targets will not execute.
440            foreach target $args {
441                                if {[info commands $target] != ""} {
442                                        ui_error "$name attempted to register provide \'$target\' which is a pre-existing procedure. Ignoring register."
443                                        continue;
444                                }
445                set ident [lindex [depspec_get_matches $targets provides $args] 0]
446                set origproc [$ident get procedure]
447                                set ident [$ident get name]
448                eval "proc $target {args} \{ \n\
449                                        global target_uniqid \n\
450                                        set id \[incr target_uniqid\] \n\
451                    register $ident target proc-$target\$id \n\
452                    eval \"proc proc-$target\$id \{name\} \{ \n\
453                        if \\\[catch userproc-$target\$id result\\\] \{ \n\
454                                                        ui_info \\\$result \n\
455                                                        return 1 \n\
456                                                \} else \{ \n\
457                                                        return 0 \n\
458                                                \} \n\
459                    \}\" \n\
460                    eval \"proc do-$target \{\} \{ $origproc $target\}\" \n\
461                    makeuserproc userproc-$target\$id \$args \}"
462                eval "proc pre-$target {args} \{ \n\
463                                        global target_uniqid \n\
464                                        set id \[incr target_uniqid\] \n\
465                    register $target preflight pre-$target\$id \n\
466                    eval \"proc pre-$target\$id \{name\} \{ \n\
467                        if \\\[catch userproc-pre-$target\$id result\\\] \{ \n\
468                                                        ui_info \\\$result \n\
469                                                        return 1 \n\
470                                                \} else \{ \n\
471                                                        return 0 \n\
472                                                \} \n\
473                    \}\" \n\
474                    makeuserproc userproc-pre-$target\$id \$args \}"
475                eval "proc post-$target {args} \{ \n\
476                                        global target_uniqid \n\
477                                        set id \[incr target_uniqid\] \n\
478                    register $target postflight post-$target\$id \n\
479                    eval \"proc post-$target\$id \{name\} \{ \n\
480                        if \\\[catch userproc-post-$target\$id result\\\] \{ \n\
481                                                        ui_info \\\$result \n\
482                                                        return 1 \n\
483                                                \} else \{ \n\
484                                                        return 0 \n\
485                                                \} \n\
486                    \}\" \n\
487                    makeuserproc userproc-post-$target\$id \$args \}"
488            }
489        }
490
491        } elseif {$mode == "deplist"} {
492                $obj append $mode $args
493       
494    } elseif {$mode == "preflight"} {
495                # Find target which provides the specified name, and add a preflight.
496                # XXX: this only returns the first match, is this what we want?
497                set obj [lindex [depspec_get_matches $targets provides $name] 0]
498                $obj append pre $args
499               
500    } elseif {$mode == "postflight"} {
501                # Find target which provides the specified name, and add a preflight.
502                # XXX: this only returns the first match, is this what we want?
503                set obj [lindex [depspec_get_matches $targets provides $name] 0]
504                $obj append post $args
505        }
506}
507
508
509# unregister
510# Unregisters a target in the global target list
511# Arguments: target <target name>
512proc unregister {mode target} {
513}
514
515########### Internal Dependancy Manipulation Procedures ###########
516
517# returns a depspec by name
518proc dlist_get_by_name {dlist name} {
519        set result ""
520        foreach d $dlist {
521                if {[$d get name] == $name} {
522                        set result $d
523                        break
524                }
525        }
526        return $result
527}
528
529# returns a list of depspecs that contain the given name in the given key
530proc depspec_get_matches {dlist key value} {
531    set result [list]
532    foreach d $dlist {
533                foreach val [$d get $key] {
534                        if {$val == $value} {
535                                lappend result $d
536                        }
537                }
538    }
539    return $result
540}
541
542# Count the unmet dependencies in the dlist based on the statusdict
543proc dlist_count_unmet {dlist statusdict names} {
544    upvar $statusdict upstatusdict
545    set unmet 0
546    foreach name $names {
547                # Service was provided, check next.
548                if {[info exists upstatusdict($name)] && $upstatusdict($name) == 1} {
549                        continue
550                } else {
551                        incr unmet
552                }
553    }
554    return $unmet
555}
556
557# Returns true if any of the dependencies are pending in the dlist
558proc dlist_has_pending {dlist uses} {
559    foreach name $uses {
560                if {[llength [depspec_get_matches $dlist provides $name]] > 0} {
561                        return 1
562                }
563    }
564    return 0
565}
566
567# Get the name of the next eligible item from the dependency list
568proc generic_get_next {dlist statusdict} {
569    set nextitem ""
570    # arbitrary large number ~ INT_MAX
571    set minfailed 2000000000
572    upvar $statusdict upstatusdict
573   
574    foreach obj $dlist {               
575                # skip if unsatisfied hard dependencies
576                if {[dlist_count_unmet $dlist upstatusdict [$obj get requires]]} { continue }
577               
578                # favor item with fewest unment soft dependencies
579                set unmet [dlist_count_unmet $dlist upstatusdict [$obj get uses]]
580
581                # delay items with unmet soft dependencies that can be filled
582                if {$unmet > 0 && [dlist_has_pending $dlist [$obj get uses]]} { continue }
583               
584                if {$unmet >= $minfailed} {
585                        # not better than our last pick
586                        continue
587                } else {
588                        # better than our last pick
589                        set minfailed $unmet
590                        set nextitem $obj
591                }
592    }
593    return $nextitem
594}
595
596
597# Evaluate the list of depspecs, running each as it becomes eligible.
598# dlist is a collection of depspec objects to be run
599# get_next_proc is used to determine the best item to run
600proc dlist_evaluate {dlist get_next_proc} {
601        global portname
602       
603    # status - keys will be node names, values will be {-1, 0, 1}.
604    array set statusdict [list]
605       
606        # XXX: Do we want to evaluate this dynamically instead of statically?
607        foreach obj $dlist {
608                if {[$obj test] == 1} {
609                        foreach name [$obj get provides] {
610                                set statusdict($name) 1
611                        }
612                        ldelete dlist $obj
613                }
614        }
615   
616    # loop for as long as there are nodes in the dlist.
617    while (1) {
618                set obj [$get_next_proc $dlist statusdict]
619
620                if {$obj == ""} { 
621                        break
622                } else {
623                        set result [$obj run]
624                        # depspec->run returns an error code, so 0 == success.
625                        # translate this to the statusdict notation where 1 == success.
626                        foreach name [$obj get provides] {
627                                set statusdict($name) [expr $result == 0]
628                        }
629                       
630                        # Delete the item from the waiting list.
631                        ldelete dlist $obj
632                }
633    }
634   
635        if {[llength $dlist] > 0} {
636                # somebody broke!
637                ui_info "Warning: the following items did not execute (for $portname): "
638                foreach obj $dlist {
639                        ui_info "[$obj get name] " -nonewline
640                }
641                ui_info ""
642                return 1
643    }
644        return 0
645}
646
647proc target_run {this} {
648        global target_state_fd portname
649        set result 0
650        set procedure [$this get procedure]
651    if {$procedure != ""} {
652                set name [$this get name]
653       
654                if {[$this has init]} {
655                        set result [catch {[$this get init] $name} errstr]
656                }
657                               
658                if {[check_statefile $name $target_state_fd]} {
659                        set result 0
660                        ui_debug "Skipping completed $name ($portname)"
661                } else {
662                        # Execute pre-run procedure
663                        if {[$this has prerun]} {
664                                set result [catch {[$this get prerun] $name} errstr]
665                        }
666
667                        if {$result == 0} {
668                                foreach pre [$this get pre] {
669                                        ui_debug "Executing $pre"
670                                        set result [catch {$pre $name} errstr]
671                                        if {$result != 0} { break }
672                                }
673                        }
674
675                        if {$result == 0} {
676                                ui_debug "Executing $name ($portname)"
677                                set result [catch {$procedure $name} errstr]
678                        }
679                       
680                        if {$result == 0} {
681                                foreach post [$this get post] {
682                                        ui_debug "Executing $post"
683                                        set result [catch {$post $name} errstr]
684                                        if {$result != 0} { break }
685                                }
686                        }
687                        # Execute post-run procedure
688                        if {[$this has postrun] && $result == 0} {
689                                set postrun [$this get postrun]
690                                ui_debug "Executing $postrun"
691                                set result [catch {$postrun $name} errstr]
692                        }
693                }
694                if {$result == 0} {
695                        if {[$this get runtype] != "always"} {
696                                write_statefile $name $target_state_fd
697                        }
698                } else {
699                        ui_error "Target error: $name returned $errstr"
700                        set result 1
701                }
702               
703    } else {
704                ui_info "Warning: $name does not have a registered procedure"
705                set result 1
706    }
707
708    return $result
709}
710
711proc eval_targets {target} {
712        global targets target_state_fd
713        set dlist $targets
714
715    # Select the subset of targets under $target
716    if {$target != ""} {
717                # XXX munge target. install really means registry, then install
718                # If more than one target ever needs this, make this a generic interface
719                if {$target == "install"} {
720                        set target registry
721                }
722        set matches [depspec_get_matches $dlist provides $target]
723        if {[llength $matches] > 0} {
724                        set dlist [dlist_append_dependents $dlist [lindex $matches 0] [list]]
725                # Special-case 'all'
726        } elseif {$target != "all"} {
727            ui_info "unknown target: $target"
728            return 1
729        }
730    }
731       
732    # Restore the state from a previous run.
733    set target_state_fd [open_statefile]
734   
735    set ret [dlist_evaluate $dlist generic_get_next]
736
737    close $target_state_fd
738        return $ret
739}
740
741# returns the names of dependents of <name> from the <itemlist>
742proc dlist_append_dependents {dlist obj result} {
743
744        # Append the item to the list, avoiding duplicates
745        if {[lsearch $result $obj] == -1} {
746                lappend result $obj
747        }
748       
749    # Recursively append any hard dependencies
750        foreach dep [$obj get requires] {
751                foreach provider [depspec_get_matches $dlist provides $dep] {
752                        set result [dlist_append_dependents $dlist $provider $result]
753        }
754    }
755    # XXX: add soft-dependencies?
756        return $result
757}
758
759# open_statefile
760# open file to store name of completed targets
761proc open_statefile {args} {
762    global portpath workdir
763
764    if ![file isdirectory $portpath/$workdir] {
765        file mkdir $portpath/$workdir
766    }
767    # flock Portfile
768    set statefile [file join $portpath $workdir .darwinports.state]
769    if {[file exists $statefile] && ![file writable $statefile]} {
770        return -code error "$statefile is not writable - check permission on port directory"
771    }
772    set fd [open $statefile a+]
773    if [catch {flock $fd -exclusive -noblock} result] {
774        if {"$result" == "EAGAIN"} {
775            ui_puts "Waiting for lock on $statefile"
776        } elseif {"$result" == "EOPNOTSUPP"} {
777            # Locking not supported, just return
778            return $fd
779        } else {
780            return -code error "$result obtaining lock on $statefile"
781        }
782    }
783    flock $fd -exclusive
784    return $fd
785}
786
787# check_statefile
788# Check completed state of target $name
789proc check_statefile {name fd} {
790    global portpath workdir
791
792    seek $fd 0
793    while {[gets $fd line] >= 0} {
794        if {[string equal $line $name]} {
795            return 1
796        }
797    }
798    return 0
799}
800
801# write_statefile
802# Set target $name completed in the state file
803proc write_statefile {name fd} {
804    if {[check_statefile $name $fd]} {
805        return 0
806    }
807    seek $fd 0 end
808    puts $fd $name
809    flush $fd
810}
811
812# Traverse the ports collection hierarchy and call procedure func for
813# each directory containing a Portfile
814proc port_traverse {func {dir .}} {
815    set pwd [pwd]
816    if [catch {cd $dir} err] {
817        ui_error $err
818        return
819    }
820    foreach name [readdir .] {
821        if {[string match $name .] || [string match $name ..]} {
822            continue
823        }
824        if [file isdirectory $name] {
825            port_traverse $func $name
826        } else {
827            if [string match $name Portfile] {
828                catch {eval $func {[file join $pwd $dir]}}
829            }
830        }
831    }
832    cd $pwd
833}
834
835
836########### Port Variants ###########
837
838# Each variant which provides a subset of the requested variations
839# will be chosen.  Returns a list of the selected variants.
840proc choose_variants {dlist variations} {
841    upvar $variations upvariations
842
843    set selected [list]
844   
845    foreach obj $dlist {
846                # Enumerate through the provides, tallying the pros and cons.
847                set pros 0
848                set cons 0
849                set ignored 0
850                foreach flavor [$obj get provides] {
851                        if {[info exists upvariations($flavor)]} {
852                                if {$upvariations($flavor) == "+"} {
853                                        incr pros
854                                } elseif {$upvariations($flavor) == "-"} {
855                                        incr cons
856                                }
857                        } else {
858                                incr ignored
859                        }
860                }
861               
862                if {$cons > 0} { continue }
863               
864                if {$pros > 0 && $ignored == 0} {
865                        lappend selected $obj
866                }
867        }
868    return $selected
869}
870
871proc variant_run {this} {
872        set name [$this get name]
873    ui_debug "Executing $name provides [$this get provides]"
874    makeuserproc $name-code "\{[$this get code]\}"
875    if ([catch $name-code result]) {
876                ui_error "Error executing $name: $result"
877                return 1
878        }
879    return 0
880}
881
882proc eval_variants {variations} {
883        global variants
884        set dlist $variants
885        upvar $variations upvariations
886        set chosen [choose_variants $dlist upvariations]
887   
888        # now that we've selected variants, change all provides [a b c] to [a-b-c]
889    # this will eliminate ambiguity between item a, b, and a-b while fulfilling requirments.
890    #foreach obj $dlist {
891    #    $obj set provides [list [join [$obj get provides] -]]
892    #}
893       
894        set newlist [list]
895    foreach variant $chosen {
896        set newlist [dlist_append_dependents $dlist $variant $newlist]
897    }
898
899    dlist_evaluate $newlist generic_get_next
900}
901
902##### DEPSPEC #####
903
904# Object-Oriented Depspecs
905#
906# Each depspec will have its data stored in an array
907# (indexed by field name) and its procedures will be
908# called via the dispatch procedure that is returned
909# from depspec_new.
910#
911# sample usage:
912# set obj [depspec_new]
913# $obj set name "hello"
914#
915
916# Depspec
917#       str name
918#       str provides[]
919#       str requires[]
920#       str uses[]
921
922global depspec_uniqid
923set depspec_uniqid 0
924
925# Depspec class definition.
926global depspec_vtbl
927set depspec_vtbl(test) depspec_test
928set depspec_vtbl(run) depspec_run
929
930# constructor for abstract depspec class
931proc depspec_new {name} {
932        global depspec_uniqid
933        set id [incr depspec_uniqid]
934       
935        # declare the array of data
936        set data dpspc_data_${id}
937        set disp dpspc_disp_${id}
938       
939        global $data 
940        set ${data}(name) $name
941        set ${data}(_vtbl) depspec_vtbl
942       
943        eval "proc $disp {method args} { \n \
944                        global $data \n \
945                        eval return \\\[depspec_dispatch $disp $data \$method \$args\\\] \n \
946                }"
947       
948        return $disp
949}
950
951# is the only proc to get access to the object's data
952# so the get/set routines are defined here.  this lets
953# the virtual members get a real "this" object.
954proc depspec_dispatch {this data method args} {
955        global $data
956        switch $method {
957                get {
958                        set prop [lindex $args 0]
959                        if {[eval info exists ${data}($prop)]} {
960                                eval return $${data}($prop)
961                        } else {
962                                return ""
963                        }
964                }
965                set {
966                        set prop [lindex $args 0]
967                        eval "set ${data}($prop) [lrange $args 1 end]"
968                }
969                has {
970                        set prop [lindex $args 0]
971                        return [info exists ${data}($prop)]
972                }
973                append {
974                        set prop [lindex $args 0]
975                        set vals [join [lrange $args 1 end] " "]
976                        eval "lappend ${data}($prop) $vals"
977                }
978                default {
979                        eval set vtbl $${data}(_vtbl)
980                        global $vtbl
981                        if {[info exists ${vtbl}($method)]} {
982                                eval set function $${vtbl}($method)
983                                eval "return \[$function $this $args\]"
984                        } else {
985                                ui_error "unknown method: $method"
986                        }
987                }
988        }
989        return ""
990}
991
992proc depspec_test {this} {
993        return 0
994}
995
996proc depspec_run {this} {
997        return 0
998}
999
1000##### target depspec subclass #####
1001
1002# Target class definition.
1003global target_vtbl
1004array set target_vtbl [array get depspec_vtbl]
1005set target_vtbl(run) target_run
1006
1007# constructor for target depspec class
1008proc target_new {name} {
1009        set obj [depspec_new $name]
1010       
1011        $obj set _vtbl target_vtbl
1012
1013        return $obj
1014}
1015
1016##### variant depspec subclass #####
1017
1018# Variant class definition.
1019global variant_vtbl
1020array set variant_vtbl [array get depspec_vtbl]
1021set variant_vtbl(run) variant_run
1022
1023# constructor for target depspec class
1024proc variant_new {name} {
1025        set obj [depspec_new $name]
1026       
1027        $obj set _vtbl variant_vtbl
1028
1029        return $obj
1030}
1031
1032
1033
1034##### portfile depspec subclass #####
1035global portfile_vtbl
1036array set portfile_vtbl [array get depspec_vtbl]
1037set portfile_vtbl(run) portfile_run
1038set portfile_vtbl(test) portfile_test
1039
1040proc portfile_new {name} {
1041        set obj [depspec_new $name]
1042       
1043        $obj set _vtbl portfile_vtbl
1044       
1045        return $obj
1046}
1047
1048# build the specified portfile
1049proc portfile_run {this} {
1050        set portname [$this get name]
1051       
1052    ui_debug "Building $portname"
1053    array set options [list]
1054    array set variations [list]
1055    array set portinfo [dportmatch ^$portname\$]
1056    if {[array size portinfo] == 0} {
1057        ui_error "Dependency $portname not found"
1058        return -1
1059    }
1060    set porturl $portinfo(porturl)
1061
1062    set worker [dportopen $porturl options variations]
1063        if {[catch {dportexec $worker clean} result] || $result != 0} {
1064                ui_error "Clean of $portname before build failed: $result"
1065                dportclose $worker
1066                return -1
1067    }
1068        if {[catch {dportexec $worker install} result] || $result != 0} {
1069                ui_error "Build of $portname failed: $result"
1070                dportclose $worker
1071                return -1
1072        }
1073        if {[catch {dportexec $worker clean} result] || $result != 0} {
1074                ui_error "Clean of $portname after build failed: $result"
1075    }
1076    dportclose $worker
1077       
1078        return 0
1079}
1080
1081proc portfile_test {this} {
1082        set receipt [registry_exists [$this get name]]
1083        if {$receipt != ""} {
1084                ui_debug "Found Dependency: receipt: $receipt"
1085                return 1
1086        } else {
1087                return 0
1088        }
1089}
1090
1091proc portfile_search_path {depregex search_path} {
1092        set found 0
1093    foreach path $search_path {
1094                if {![file isdirectory $path]} {
1095                        continue
1096                }
1097                foreach filename [readdir $path] {
1098                        if {[regexp $depregex $filename] == 1} {
1099                                ui_debug "Found Dependency: path: $path filename: $filename regex: $depregex"
1100                                set found 1
1101                                break
1102                        }
1103                }
1104        }
1105        return $found
1106}
1107
1108
1109
1110##### lib portfile depspec subclass #####
1111global libportfile_vtbl
1112array set libportfile_vtbl [array get portfile_vtbl]
1113set libportfile_vtbl(test) libportfile_test
1114
1115proc libportfile_new {name match} {
1116        set obj [portfile_new $name]
1117       
1118        $obj set _vtbl libportfile_vtbl
1119        $obj set depregex $match
1120       
1121        return $obj
1122}
1123
1124# XXX - Architecture specific
1125# XXX - Rely on information from internal defines in cctools/dyld:
1126# define DEFAULT_FALLBACK_FRAMEWORK_PATH
1127# /Library/Frameworks:/Library/Frameworks:/Network/Library/Frameworks:/System/Library/Frameworks
1128# define DEFAULT_FALLBACK_LIBRARY_PATH /lib:/usr/local/lib:/lib:/usr/lib
1129# Environment variables DYLD_FRAMEWORK_PATH, DYLD_LIBRARY_PATH,
1130# DYLD_FALLBACK_FRAMEWORK_PATH, and DYLD_FALLBACK_LIBRARY_PATH take precedence
1131
1132proc libportfile_test {this} {
1133        global env prefix
1134
1135        # Check the registry first
1136        set result [portfile_test $this]
1137        if {$result == 1} {
1138                return $result
1139        } else {
1140                # Not in the registry, check the library path.
1141                set depregex [$this get depregex]
1142               
1143                if {[info exists env(DYLD_FRAMEWORK_PATH)]} {
1144                lappend search_path $env(DYLD_FRAMEWORK_PATH)
1145                } else {
1146                lappend search_path /Library/Frameworks /Network/Library/Frameworks /System/Library/Frameworks
1147                }
1148                if {[info exists env(DYLD_FALLBACK_FRAMEWORK_PATH)]} {
1149                lappend search_path $env(DYLD_FALLBACK_FRAMEWORK_PATH)
1150                }
1151                if {[info exists env(DYLD_LIBRARY_PATH)]} {
1152                lappend search_path $env(DYLD_LIBRARY_PATH)
1153                } else {
1154                lappend search_path /lib /usr/local/lib /lib /usr/lib /op/local/lib /usr/X11R6/lib ${prefix}/lib
1155                }
1156                if {[info exists env(DYLD_FALLBACK_LIBRARY_PATH)]} {
1157                lappend search_path $env(DYLD_LIBRARY_PATH)
1158                }
1159                regsub {\.} $depregex {\.} depregex
1160                set depregex \^$depregex.*\\.dylib\$
1161
1162                return [portfile_search_path $depregex $search_path]
1163        }
1164}
1165
1166##### bin portfile depspec subclass #####
1167global binportfile_vtbl
1168array set binportfile_vtbl [array get portfile_vtbl]
1169set binportfile_vtbl(test) binportfile_test
1170
1171proc binportfile_new {name match} {
1172        set obj [portfile_new $name]
1173       
1174        $obj set _vtbl binportfile_vtbl
1175        $obj set depregex $match
1176
1177        return $obj
1178}
1179
1180proc binportfile_test {this} {
1181        global env prefix
1182
1183        # Check the registry first
1184        set result [portfile_test $this]
1185        if {$result == 1} {
1186                return $result
1187        } else {
1188                # Not in the registry, check the binary path.
1189                set depregex [$this get depregex]
1190
1191                set search_path [split $env(PATH) :]
1192               
1193                set depregex \^$depregex\$
1194
1195                return [portfile_search_path $depregex $search_path]
1196        }
1197}
Note: See TracBrowser for help on using the repository browser.