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

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

rolling back overzealous escaping of '.' for binary regexps.

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