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

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

Discard statefile if Portfile changed since last build.

  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 36.9 KB
Line 
1# et: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
34package require msgcat
35
36global targets target_uniqid all_variants
37
38set targets [list]
39set target_uniqid 0
40
41set all_variants [list]
42
43########### External High Level Procedures ###########
44
45namespace eval options {
46}
47
48# options
49# Exports options in an array as externally callable procedures
50# Thus, "options name date" would create procedures named "name"
51# and "date" that set global variables "name" and "date", respectively
52# When an option is modified in any way, options::$option is called,
53# if it exists
54# Arguments: <list of options>
55proc options {args} {
56    foreach option $args {
57        eval "proc $option {args} \{ \n\
58            global ${option} user_options option_procs \n\
59                \if \{!\[info exists user_options(${option})\]\} \{ \n\
60                     set ${option} \$args \n\
61                         if \{\[info exists option_procs($option)\]\} \{ \n\
62                                foreach p \$option_procs($option) \{ \n\
63                                        eval \"\$p $option set \$args\" \n\
64                                \} \n\
65                         \} \n\
66                \} \n\
67        \}"
68       
69        eval "proc ${option}-delete {args} \{ \n\
70            global ${option} user_options option_procs \n\
71                \if \{!\[info exists user_options(${option})\]\} \{ \n\
72                    foreach val \$args \{ \n\
73                        ldelete ${option} \$val \n\
74                    \} \n\
75                    if \{\[string length \$${option}\] == 0\} \{ \n\
76                        unset ${option} \n\
77                    \} \n\
78                        if \{\[info exists option_procs($option)\]\} \{ \n\
79                            foreach p \$option_procs($option) \{ \n\
80                                eval \"\$p $option delete \$args\" \n\
81                        \} \n\
82                    \} \n\
83                \} \n\
84        \}"
85        eval "proc ${option}-append {args} \{ \n\
86            global ${option} user_options option_procs \n\
87                \if \{!\[info exists user_options(${option})\]\} \{ \n\
88                    if \{\[info exists ${option}\]\} \{ \n\
89                        set ${option} \[concat \$\{$option\} \$args\] \n\
90                    \} else \{ \n\
91                        set ${option} \$args \n\
92                    \} \n\
93                    if \{\[info exists option_procs($option)\]\} \{ \n\
94                        foreach p \$option_procs($option) \{ \n\
95                            eval \"\$p $option append \$args\" \n\
96                        \} \n\
97                    \} \n\
98                \} \n\
99        \}"
100    }
101}
102
103proc options_export {args} {
104    foreach option $args {
105        eval "proc options::${option} \{args\} \{ \n\
106            global ${option} PortInfo \n\
107            if \{\[info exists ${option}\]\} \{ \n\
108                set PortInfo(${option}) \$${option} \n\
109            \} else \{ \n\
110                unset PortInfo(${option}) \n\
111            \} \n\
112        \}"
113        option_proc ${option} options::${option}
114    }
115}
116
117# option_deprecate
118# Causes a warning to be printed when an option is set or accessed
119proc option_deprecate {option {newoption ""} } {
120    # If a new option is specified, default the option to {${newoption}}
121    # Display a warning
122    if {$newoption != ""} {
123        eval "proc warn_deprecated_$option \{option action args\} \{ \n\
124            global portname $option $newoption \n\
125            if \{\$action != \"read\"\} \{ \n\
126                $newoption \$$option \n\
127            \} else \{ \n\
128                ui_warn \"Port \$portname using deprecated option \\\"$option\\\".\" \n\
129                $option \[set $newoption\] \n\
130            \} \n\
131        \}"
132    } else {
133        eval "proc warn_deprecated_$option \{option action args\} \{ \n\
134            global portname $option $newoption \n\
135            ui_warn \"Port \$portname using deprecated option \\\"$option\\\".\" \n\
136        \}"
137    }
138    option_proc $option warn_deprecated_$option
139}
140
141proc option_proc {option args} {
142    global option_procs $option
143    eval "lappend option_procs($option) $args"
144    # Add a read trace to the variable, as the option procedures have no access to reads
145    trace variable $option r option_proc_trace
146}
147
148# option_proc_trace
149# trace handler for option reads. Calls option procedures with correct arguments.
150proc option_proc_trace {optionName index op} {
151    global option_procs
152    foreach p $option_procs($optionName) {
153        eval "$p $optionName read"
154    }
155}
156
157# commands
158# Accepts a list of arguments, of which several options are created
159# and used to form a standard set of command options.
160proc commands {args} {
161    foreach option $args {
162        options use_${option} ${option}.dir ${option}.pre_args ${option}.args ${option}.post_args ${option}.env ${option}.type ${option}.cmd
163    }
164}
165
166# command
167# Given a command name, command assembled a string
168# composed of the command options.
169proc command {command} {
170    global ${command}.dir ${command}.pre_args ${command}.args ${command}.post_args ${command}.env ${command}.type ${command}.cmd
171   
172    set cmdstring ""
173    if [info exists ${command}.dir] {
174        set cmdstring "cd [set ${command}.dir] &&"
175    }
176   
177    if [info exists ${command}.env] {
178        foreach string [set ${command}.env] {
179            set cmdstring "$cmdstring $string"
180        }
181    }
182   
183    if [info exists ${command}.cmd] {
184        foreach string [set ${command}.cmd] {
185            set cmdstring "$cmdstring $string"
186        }
187    } else {
188        set cmdstring "$cmdstring ${command}"
189    }
190    foreach var "${command}.pre_args ${command}.args ${command}.post_args" {
191        if [info exists $var] {
192            foreach string [set ${var}] {
193                set cmdstring "$cmdstring $string"
194            }
195        }
196    }
197    ui_debug "Assembled command: '$cmdstring'"
198    return $cmdstring
199}
200
201# default
202# Sets a variable to the supplied default if it does not exist,
203# and adds a variable trace. The variable traces allows for delayed
204# variable and command expansion in the variable's default value.
205proc default {option val} {
206    global $option option_defaults
207    if {[info exists option_defaults($option)]} {
208        ui_debug "Re-registering default for $option"
209    } else {
210        # If option is already set and we did not set it
211        # do not reset the value
212        if {[info exists $option]} {
213            return
214        }
215    }
216    set option_defaults($option) $val
217    set $option $val
218    trace variable $option rwu default_check
219}
220
221# default_check
222# trace handler to provide delayed variable & command expansion
223# for default variable values
224proc default_check {optionName index op} {
225    global option_defaults $optionName
226    switch $op {
227        w {
228            unset option_defaults($optionName)
229            trace vdelete $optionName rwu default_check
230            return
231        }
232        r {
233            upvar $optionName option
234            uplevel #0 set $optionName $option_defaults($optionName)
235            return
236        }
237        u {
238            unset option_defaults($optionName)
239            trace vdelete $optionName rwu default_check
240            return
241        }
242    }
243}
244
245# variant <provides> [<provides> ...] [requires <requires> [<requires>]]
246# Portfile level procedure to provide support for declaring variants
247proc variant {args} {
248    global all_variants PortInfo
249    upvar $args upargs
250   
251    set len [llength $args]
252    set code [lindex $args end]
253    set args [lrange $args 0 [expr $len - 2]]
254   
255    set obj [variant_new "temp-variant"]
256   
257    # mode indicates what the arg is interpreted as.
258        # possible mode keywords are: requires, conflicts, provides
259        # The default mode is provides.  Arguments are added to the
260        # most recently specified mode (left to right).
261    set mode "provides"
262    foreach arg $args {
263                switch -exact $arg {
264                        provides { set mode "provides" }
265                        requires { set mode "requires" }
266                        conflicts { set mode "conflicts" }
267                        default { $obj append $mode $arg }             
268        }
269    }
270    $obj set name "[join [$obj get provides] -]"
271
272    # make a user procedure named variant-blah-blah
273    # we will call this procedure during variant-run
274    makeuserproc "variant-[$obj get name]" \{$code\}
275    lappend all_variants $obj
276   
277    # Export provided variant to PortInfo
278    lappend PortInfo(variants) [$obj get provides]
279}
280
281# variant_isset name
282# Returns 1 if variant name selected, otherwise 0
283proc variant_isset {name} {
284    global variations
285   
286    if {[info exists variations($name)] && $variations($name) == "+"} {
287        return 1
288    }
289    return 0
290}
291
292# variant_set name
293# Sets variant to run for current portfile
294proc variant_set {name} {
295    global variations
296   
297    set variations($name) +
298}
299
300# variant_unset name
301# Clear variant for current portfile
302proc variant_unset {name} {
303    global variations
304
305    set variations($name) -
306}
307
308########### Misc Utility Functions ###########
309
310# tbool (testbool)
311# If the variable exists in the calling procedure's namespace
312# and is set to "yes", return 1. Otherwise, return 0
313proc tbool {key} {
314    upvar $key $key
315    if {[info exists $key]} {
316        if {[string equal -nocase [set $key] "yes"]} {
317            return 1
318        }
319    }
320    return 0
321}
322
323# ldelete
324# Deletes a value from the supplied list
325proc ldelete {list value} {
326    upvar $list uplist
327    set ix [lsearch -exact $uplist $value]
328    if {$ix >= 0} {
329        set uplist [lreplace $uplist $ix $ix]
330    }
331}
332
333# reinplace
334# Provides "sed in place" functionality
335proc reinplace {oddpattern file}  {
336    set backpattern [strsed $oddpattern {g/\//\\\\\//}]
337    set pattern [strsed $backpattern {g/\|/\//}]
338
339    if {[catch {set tmpfile [mktemp "/tmp/[file tail $file].sed.XXXXXXXX"]} error]} {
340        ui_error "reinplace: $error"
341        return -code error "reinplace failed"
342    }
343
344    if {[catch {exec sed $pattern < $file > $tmpfile} error]} {
345        ui_error "reinplace: $error"
346        file delete "$tmpfile"
347        return -code error "reinplace failed"
348    }
349
350    if {[catch {exec cp $tmpfile $file} error]} {
351        ui_error "reinplace: $error"
352        file delete "$tmpfile"
353        return -code error "reinplace failed"
354    }
355    file delete "$tmpfile"
356    return
357}
358
359# filefindbypath
360# Provides searching of the standard path for included files
361proc filefindbypath {fname} {
362    global distpath filedir workdir worksrcdir portpath
363
364    if [file readable $fname] {
365        return $fname
366    } elseif [file readable $portpath/$fname] {
367        return $portpath/$fname
368    } elseif [file readable $portpath/$filedir/$fname] {
369        return $portpath/$filedir/$fname
370    } elseif [file readable $distpath/$fname] {
371        return $distpath/$fname
372    } elseif [file readable $portpath/$workdir/$worksrcdir/$fname] {
373        return $portpath/$workdir/$worksrcdir/$fname
374    } elseif [file readable [file join /etc $fname]] {
375        return [file join /etc $fname]
376    }
377    return ""
378}
379
380# include
381# Source a file, looking for it along a standard search path.
382proc include {fname} {
383    set tgt [filefindbypath $fname]
384    if [string length $tgt] {
385        uplevel "source $tgt"
386    } else {
387        return -code error "Unable to find include file $fname"
388    }
389}
390
391# makeuserproc
392# This procedure re-writes the user-defined custom target to include
393# all the globals in its scope.  This is undeniably ugly, but I haven't
394# thought of any other way to do this.
395proc makeuserproc {name body} {
396    regsub -- "^\{(.*?)" $body "\{ \n foreach g \[info globals\] \{ \n global \$g \n \} \n \\1" body
397    eval "proc $name {} $body"
398}
399
400########### Internal Dependancy Manipulation Procedures ###########
401
402# returns a depspec by name
403proc dlist_get_by_name {dlist name} {
404    set result ""
405    foreach d $dlist {
406        if {[$d get name] == $name} {
407            set result $d
408            break
409        }
410    }
411    return $result
412}
413
414# returns a list of depspecs that contain the given name in the given key
415proc depspec_get_matches {dlist key value} {
416    set result [list]
417    foreach d $dlist {
418        foreach val [$d get $key] {
419            if {$val == $value} {
420                lappend result $d
421            }
422        }
423    }
424    return $result
425}
426
427# Count the unmet dependencies in the dlist based on the statusdict
428proc dlist_count_unmet {dlist statusdict names} {
429    upvar $statusdict upstatusdict
430    set unmet 0
431    foreach name $names {
432        # Service was provided, check next.
433        if {[info exists upstatusdict($name)] && $upstatusdict($name) == 1} {
434            continue
435        } else {
436            incr unmet
437        }
438    }
439    return $unmet
440}
441
442# Returns true if any of the dependencies are pending in the dlist
443proc dlist_has_pending {dlist uses} {
444    foreach name $uses {
445        if {[llength [depspec_get_matches $dlist provides $name]] > 0} {
446            return 1
447        }
448    }
449    return 0
450}
451
452# Get the name of the next eligible item from the dependency list
453proc generic_get_next {dlist statusdict} {
454    set nextitem ""
455    # arbitrary large number ~ INT_MAX
456    set minfailed 2000000000
457    upvar $statusdict upstatusdict
458   
459    foreach obj $dlist {               
460        # skip if unsatisfied hard dependencies
461        if {[dlist_count_unmet $dlist upstatusdict [$obj get requires]]} { continue }
462       
463        # favor item with fewest unment soft dependencies
464        set unmet [dlist_count_unmet $dlist upstatusdict [$obj get uses]]
465       
466        # delay items with unmet soft dependencies that can be filled
467        if {$unmet > 0 && [dlist_has_pending $dlist [$obj get uses]]} { continue }
468       
469        if {$unmet >= $minfailed} {
470            # not better than our last pick
471            continue
472        } else {
473            # better than our last pick
474            set minfailed $unmet
475            set nextitem $obj
476        }
477    }
478    return $nextitem
479}
480
481
482# Evaluate the list of depspecs, running each as it becomes eligible.
483# dlist is a collection of depspec objects to be run
484# get_next_proc is used to determine the best item to run
485proc dlist_evaluate {dlist get_next_proc} {
486    global portname
487   
488    # status - keys will be node names, values will be {-1, 0, 1}.
489    array set statusdict [list]
490   
491    # XXX: Do we want to evaluate this dynamically instead of statically?
492    foreach obj $dlist {
493        if {[$obj test] == 1} {
494            foreach name [$obj get provides] {
495                set statusdict($name) 1
496            }
497            ldelete dlist $obj
498        }
499    }
500   
501    # loop for as long as there are nodes in the dlist.
502    while (1) {
503        set obj [$get_next_proc $dlist statusdict]
504       
505        if {$obj == ""} { 
506            break
507        } else {
508            catch {$obj run} result
509            # depspec->run returns an error code, so 0 == success.
510            # translate this to the statusdict notation where 1 == success.
511            foreach name [$obj get provides] {
512                set statusdict($name) [expr $result == 0]
513            }
514           
515            # Delete the item from the waiting list.
516            ldelete dlist $obj
517        }
518    }
519   
520    if {[llength $dlist] > 0} {
521        # somebody broke!
522        ui_info "Warning: the following items did not execute (for $portname): "
523        foreach obj $dlist {
524            ui_info "[$obj get name] " -nonewline
525        }
526        ui_info ""
527        return 1
528    }
529    return 0
530}
531
532proc target_run {this} {
533    global target_state_fd portname
534    set result 0
535    set procedure [$this get procedure]
536    if {$procedure != ""} {
537        set name [$this get name]
538       
539        if {[$this has init]} {
540            set result [catch {[$this get init] $name} errstr]
541        }
542       
543        if {[check_statefile target $name $target_state_fd] && $result == 0} {
544            set result 0
545            ui_debug "Skipping completed $name ($portname)"
546        } elseif {$result == 0} {
547            # Execute pre-run procedure
548            if {[$this has prerun]} {
549                set result [catch {[$this get prerun] $name} errstr]
550            }
551           
552            if {$result == 0} {
553                foreach pre [$this get pre] {
554                    ui_debug "Executing $pre"
555                    set result [catch {$pre $name} errstr]
556                    if {$result != 0} { break }
557                }
558            }
559           
560            if {$result == 0} {
561                ui_debug "Executing $name ($portname)"
562                set result [catch {$procedure $name} errstr]
563            }
564           
565            if {$result == 0} {
566                foreach post [$this get post] {
567                    ui_debug "Executing $post"
568                    set result [catch {$post $name} errstr]
569                    if {$result != 0} { break }
570                }
571            }
572            # Execute post-run procedure
573            if {[$this has postrun] && $result == 0} {
574                set postrun [$this get postrun]
575                ui_debug "Executing $postrun"
576                set result [catch {$postrun $name} errstr]
577            }
578        }
579        if {$result == 0} {
580            if {[$this get runtype] != "always"} {
581                write_statefile target $name $target_state_fd
582            }
583        } else {
584            ui_error "Target $name returned: $errstr"
585            set result 1
586        }
587       
588    } else {
589        ui_info "Warning: $name does not have a registered procedure"
590        set result 1
591    }
592   
593    return $result
594}
595
596proc eval_targets {target} {
597    global targets target_state_fd
598    set dlist $targets
599   
600    # Select the subset of targets under $target
601    if {$target != ""} {
602        set matches [depspec_get_matches $dlist provides $target]
603        if {[llength $matches] > 0} {
604            set dlist [dlist_append_dependents $dlist [lindex $matches 0] [list]]
605            # Special-case 'all'
606        } elseif {$target != "all"} {
607            ui_info "unknown target: $target"
608            return 1
609        }
610    }
611   
612    # Restore the state from a previous run.
613    set target_state_fd [open_statefile]
614   
615    set ret [dlist_evaluate $dlist generic_get_next]
616   
617    close $target_state_fd
618    return $ret
619}
620
621# returns the names of dependents of <name> from the <itemlist>
622proc dlist_append_dependents {dlist obj result} {
623   
624    # Append the item to the list, avoiding duplicates
625    if {[lsearch $result $obj] == -1} {
626        lappend result $obj
627    }
628   
629    # Recursively append any hard dependencies
630    foreach dep [$obj get requires] {
631        foreach provider [depspec_get_matches $dlist provides $dep] {
632            set result [dlist_append_dependents $dlist $provider $result]
633        }
634    }
635    # XXX: add soft-dependencies?
636    return $result
637}
638
639# open_statefile
640# open file to store name of completed targets
641proc open_statefile {args} {
642    global workpath portname portpath
643   
644    if ![file isdirectory $workpath ] {
645        file mkdir $workpath
646    }
647    # flock Portfile
648    set statefile [file join $workpath .darwinports.${portname}.state]
649    if {[file exists $statefile]} {
650                if {![file writable $statefile]} {
651                        return -code error "$statefile is not writable - check permission on port directory"
652                }
653                if {[file mtime $statefile] < [file mtime ${portpath}/Portfile]} {
654                        ui_msg "Portfile changed since last build; discarding previous state."
655                        file delete $statefile
656                }
657        }
658       
659    set fd [open $statefile a+]
660    if [catch {flock $fd -exclusive -noblock} result] {
661        if {"$result" == "EAGAIN"} {
662            ui_msg "Waiting for lock on $statefile"
663        } elseif {"$result" == "EOPNOTSUPP"} {
664            # Locking not supported, just return
665            return $fd
666        } else {
667            return -code error "$result obtaining lock on $statefile"
668        }
669    }
670    flock $fd -exclusive
671    return $fd
672}
673
674# check_statefile
675# Check completed/selected state of target/variant $name
676proc check_statefile {class name fd} {
677    global portpath workdir
678       
679    seek $fd 0
680    while {[gets $fd line] >= 0} {
681                if {$line == "$class: $name"} {
682                        return 1
683                }
684    }
685    return 0
686}
687
688# write_statefile
689# Set target $name completed in the state file
690proc write_statefile {class name fd} {
691    if {[check_statefile $class $name $fd]} {
692                return 0
693    }
694    seek $fd 0 end
695    puts $fd "$class: $name"
696    flush $fd
697}
698
699# check_statefile_variants
700# Check that recorded selection of variants match the current selection
701proc check_statefile_variants {variations fd} {
702        upvar $variations upvariations
703       
704    seek $fd 0
705    while {[gets $fd line] >= 0} {
706                if {[regexp "variant: (.*)" $line match name]} {
707                        set oldvariations([string range $name 1 end]) [string range $name 0 0]
708                }
709    }
710
711        set mismatch 0
712        if {[array size oldvariations] > 0} {
713                if {[array size oldvariations] != [array size upvariations]} {
714                        set mismatch 1
715                } else {
716                        foreach key [array names upvariations *] {
717                                if {$upvariations($key) != $oldvariations($key)} {
718                                        set mismatch 1
719                                        break
720                                }
721                        }
722                }
723        }
724
725        return $mismatch
726}
727
728# Traverse the ports collection hierarchy and call procedure func for
729# each directory containing a Portfile
730proc port_traverse {func {dir .}} {
731    set pwd [pwd]
732    if [catch {cd $dir} err] {
733        ui_error $err
734        return
735    }
736    foreach name [readdir .] {
737        if {[string match $name .] || [string match $name ..]} {
738            continue
739        }
740        if [file isdirectory $name] {
741            port_traverse $func $name
742        } else {
743            if [string match $name Portfile] {
744                catch {eval $func {[file join $pwd $dir]}}
745            }
746        }
747    }
748    cd $pwd
749}
750
751
752########### Port Variants ###########
753
754# Each variant which provides a subset of the requested variations
755# will be chosen.  Returns a list of the selected variants.
756proc choose_variants {dlist variations} {
757    upvar $variations upvariations
758   
759    set selected [list]
760   
761    foreach obj $dlist {
762        # Enumerate through the provides, tallying the pros and cons.
763        set pros 0
764        set cons 0
765        set ignored 0
766        foreach flavor [$obj get provides] {
767            if {[info exists upvariations($flavor)]} {
768                if {$upvariations($flavor) == "+"} {
769                    incr pros
770                } elseif {$upvariations($flavor) == "-"} {
771                    incr cons
772                }
773            } else {
774                incr ignored
775            }
776        }
777       
778        if {$cons > 0} { continue }
779       
780        if {$pros > 0 && $ignored == 0} {
781            lappend selected $obj
782        }
783    }
784    return $selected
785}
786
787proc variant_run {this} {
788    set name [$this get name]
789    ui_debug "Executing $name provides [$this get provides]"
790
791        # test for conflicting variants
792        foreach v [$this get conflicts] {
793                if {[variant_isset $v]} {
794                        ui_error "Variant $name conflicts with $v"
795                        return 1
796                }
797        }
798
799    # execute proc with same name as variant.
800    if {[catch "variant-${name}" result]} {
801        ui_error "Error executing $name: $result"
802        return 1
803    }
804    return 0
805}
806
807proc eval_variants {variations target} {
808    global all_variants ports_force
809    set dlist $all_variants
810        set result 0
811    upvar $variations upvariations
812    set chosen [choose_variants $dlist upvariations]
813   
814    # now that we've selected variants, change all provides [a b c] to [a-b-c]
815    # this will eliminate ambiguity between item a, b, and a-b while fulfilling requirments.
816    #foreach obj $dlist {
817    #    $obj set provides [list [join [$obj get provides] -]]
818    #}
819   
820    set newlist [list]
821    foreach variant $chosen {
822        set newlist [dlist_append_dependents $dlist $variant $newlist]
823    }
824   
825    dlist_evaluate $newlist generic_get_next
826       
827        # Make sure the variations match those stored in the statefile.
828        # If they don't match, print an error indicating a 'port clean'
829        # should be performed. 
830        # - Skip this test if the statefile is empty.
831        # - Skip this test if performing a clean.
832        # - Skip this test if ports_force was specified.
833
834        if {$target != "clean" && 
835                !([info exists ports_force] && $ports_force == "yes")} {
836                set state_fd [open_statefile]
837       
838                if {[check_statefile_variants upvariations $state_fd]} {
839                        ui_error "Requested variants do not match original selection.\nPlease perform 'port clean' or specify the force option."
840                        set result 1
841                } else {
842                        # Write variations out to the statefile
843                        foreach key [array names upvariations *] {
844                                write_statefile variant $upvariations($key)$key $state_fd
845                        }
846                }
847               
848                close $state_fd
849        }
850       
851        return $result
852}
853
854##### DEPSPEC #####
855
856# Object-Oriented Depspecs
857#
858# Each depspec will have its data stored in an array
859# (indexed by field name) and its procedures will be
860# called via the dispatch procedure that is returned
861# from depspec_new.
862#
863# sample usage:
864# set obj [depspec_new]
865# $obj set name "hello"
866#
867
868# Depspec
869#       str name
870#       str provides[]
871#       str requires[]
872#       str uses[]
873
874global depspec_uniqid
875set depspec_uniqid 0
876
877# Depspec class definition.
878global depspec_vtbl
879set depspec_vtbl(test) depspec_test
880set depspec_vtbl(run) depspec_run
881set depspec_vtbl(get) depspec_get
882set depspec_vtbl(set) depspec_set
883set depspec_vtbl(has) depspec_has
884set depspec_vtbl(append) depspec_append
885
886# constructor for abstract depspec class
887proc depspec_new {name} {
888    global depspec_uniqid
889    set id [incr depspec_uniqid]
890   
891    # declare the array of data
892    set data dpspc_data_${id}
893    set disp dpspc_disp_${id}
894   
895    global $data 
896    set ${data}(name) $name
897    set ${data}(_vtbl) depspec_vtbl
898   
899    eval "proc $disp {method args} { \n \
900                        global $data \n \
901                        eval return \\\[depspec_dispatch $disp $data \$method \$args\\\] \n \
902                }"
903   
904    return $disp
905}
906
907proc depspec_get {this prop} {
908    set data [$this _data]
909    global $data
910    if {[eval info exists ${data}($prop)]} {
911        eval return $${data}($prop)
912    } else {
913        return ""
914    }
915}
916
917proc depspec_set {this prop args} {
918    set data [$this _data]
919    global $data
920    eval "set ${data}($prop) \"$args\""
921}
922
923proc depspec_has {this prop} {
924    set data [$this _data]
925    global $data
926    eval return \[info exists ${data}($prop)\]
927}
928
929proc depspec_append {this prop args} {
930    set data [$this _data]
931    global $data
932    set vals [join $args " "]
933    eval lappend ${data}($prop) $vals
934}
935
936# is the only proc to get direct access to the object's data
937# so the _data accessor has to be defined here.  all other
938# methods are looked up in the virtual function table,
939# and are called with {$this $args}.
940proc depspec_dispatch {this data method args} {
941    global $data
942    if {$method == "_data"} { return $data }
943    eval set vtbl $${data}(_vtbl)
944    global $vtbl
945    if {[info exists ${vtbl}($method)]} {
946        eval set function $${vtbl}($method)
947        eval "return \[$function $this $args\]"
948    } else {
949        ui_error "unknown method: $method"
950    }
951    return ""
952}
953
954proc depspec_test {this} {
955    return 0
956}
957
958proc depspec_run {this} {
959    return 0
960}
961
962##### target depspec subclass #####
963
964# Target class definition.
965global target_vtbl
966array set target_vtbl [array get depspec_vtbl]
967set target_vtbl(run) target_run
968set target_vtbl(provides) target_provides
969set target_vtbl(requires) target_requires
970set target_vtbl(uses) target_uses
971set target_vtbl(deplist) target_deplist
972set target_vtbl(prerun) target_prerun
973set target_vtbl(postrun) target_postrun
974
975# constructor for target depspec class
976proc target_new {name procedure} {
977    global targets
978    set obj [depspec_new $name]
979   
980    $obj set _vtbl target_vtbl
981    $obj set procedure $procedure
982   
983    lappend targets $obj
984   
985    return $obj
986}
987
988proc target_provides {this args} {
989    global targets
990    # Register the pre-/post- hooks for use in Portfile.
991    # Portfile syntax: pre-fetch { puts "hello world" }
992    # User-code exceptions are caught and returned as a result of the target.
993    # Thus if the user code breaks, dependent targets will not execute.
994    foreach target $args {
995        set origproc [$this get procedure]
996        set ident [$this get name]
997        if {[info commands $target] != ""} {
998            ui_debug "[$this get name] registered provides \'$target\', a pre-existing procedure. Target override will not be provided"
999        } else {
1000                eval "proc $target {args} \{ \n\
1001                        $this set procedure proc-${ident}-${target}
1002                        eval \"proc proc-${ident}-${target} \{name\} \{ \n\
1003                                if \{\\\[catch userproc-${ident}-${target} result\\\]\} \{ \n\
1004                                        return -code error \\\$result \n\
1005                                \} else \{ \n\
1006                                        return 0 \n\
1007                                \} \n\
1008                        \}\" \n\
1009                        eval \"proc do-$target \{\} \{ $origproc $target\}\" \n\
1010                        makeuserproc userproc-${ident}-${target} \$args \n\
1011                \}"
1012        }
1013        eval "proc pre-$target {args} \{ \n\
1014                        $this append pre proc-pre-${ident}-${target}
1015                        eval \"proc proc-pre-${ident}-${target} \{name\} \{ \n\
1016                                if \{\\\[catch userproc-pre-${ident}-${target} result\\\]\} \{ \n\
1017                                        return -code error \\\$result \n\
1018                                \} else \{ \n\
1019                                        return 0 \n\
1020                                \} \n\
1021                        \}\" \n\
1022                        makeuserproc userproc-pre-${ident}-${target} \$args \n\
1023                \}"
1024        eval "proc post-$target {args} \{ \n\
1025                        $this append post proc-post-${ident}-${target}
1026                        eval \"proc proc-post-${ident}-${target} \{name\} \{ \n\
1027                                if \{\\\[catch userproc-post-${ident}-${target} result\\\]\} \{ \n\
1028                                        return -code error \\\$result \n\
1029                                \} else \{ \n\
1030                                        return 0 \n\
1031                                \} \n\
1032                        \}\" \n\
1033                        makeuserproc userproc-post-${ident}-${target} \$args \n\
1034                \}"
1035    }
1036    eval "depspec_append $this provides $args"
1037}
1038
1039proc target_requires {this args} {
1040    eval "depspec_append $this requires $args"
1041}
1042
1043proc target_uses {this args} {
1044    eval "depspec_append $this uses $args"
1045}
1046
1047proc target_deplist {this args} {
1048    eval "depspec_append $this deplist $args"
1049}
1050
1051proc target_prerun {this args} {
1052    eval "depspec_append $this prerun $args"
1053}
1054
1055proc target_postrun {this args} {
1056    eval "depspec_append $this postrun $args"
1057}
1058
1059##### variant depspec subclass #####
1060
1061# Variant class definition.
1062global variant_vtbl
1063array set variant_vtbl [array get depspec_vtbl]
1064set variant_vtbl(run) variant_run
1065
1066# constructor for target depspec class
1067proc variant_new {name} {
1068    set obj [depspec_new $name]
1069   
1070    $obj set _vtbl variant_vtbl
1071   
1072    return $obj
1073}
1074
1075proc handle_default_variants {option action args} {
1076    global variations
1077    switch -regex $action {
1078        set|append {
1079            foreach v $args {
1080                if {[regexp {([-+])([-A-Za-z0-9_]+)} $v whole val variant]} {
1081                    if {![info exists variations($variant)]} {
1082                        set variations($variant) $val
1083                    }
1084                }
1085            }
1086        }
1087        delete {
1088            # xxx
1089        }
1090    }
1091}
1092
1093##### portfile depspec subclass #####
1094global portfile_vtbl
1095array set portfile_vtbl [array get depspec_vtbl]
1096set portfile_vtbl(run) portfile_run
1097set portfile_vtbl(test) portfile_test
1098
1099proc portfile_new {name} {
1100    set obj [depspec_new $name]
1101   
1102    $obj set _vtbl portfile_vtbl
1103   
1104    return $obj
1105}
1106
1107# portfile primitive that calls portexec_int with newworkpath == ${workpath}
1108proc portexec {portname target} {
1109        global workpath
1110        portexec_int $portname $target $workpath
1111}
1112
1113# build the specified portfile with default workpath
1114proc portfile_run {this} {
1115    set portname [$this get name]
1116    if {![catch {portexec_int $portname install} result]} {
1117                portexec_int $portname clean
1118    }
1119    return $result
1120}
1121
1122# builds the specified port (looked up in the index) to the specified target
1123# doesn't yet support options or variants...
1124# newworkpath defines the port's workpath - useful for when one port relies
1125# on the source, etc, of another
1126proc portexec_int {portname target {newworkpath ""}} {
1127    ui_debug "Executing $target ($portname)"
1128    set variations [list]
1129    if {$newworkpath == ""} {
1130        array set options [list]
1131    } else {
1132        set options(workpath) ${newworkpath}
1133    }
1134        # Escape regex special characters
1135        regsub -all "(\\(){1}|(\\)){1}|(\\{1}){1}|(\\+){1}|(\\{1}){1}|(\\{){1}|(\\}){1}|(\\^){1}|(\\$){1}|(\\.){1}|(\\\\){1}" $portname "\\\\&" search_string
1136
1137    set res [dportsearch ^$search_string\$]
1138    if {[llength $res] < 2} {
1139        ui_error "Dependency $portname not found"
1140        return -1
1141    }
1142
1143    array set portinfo [lindex $res 1]
1144    set porturl $portinfo(porturl)
1145    if {[catch {set worker [dportopen $porturl [array get options] $variations]} result]} {
1146        ui_error "Opening $portname $target failed: $result"
1147        return -1
1148    }
1149    if {[catch {dportexec $worker $target} result] || $result != 0} {
1150        ui_error "Execution $portname $target failed: $result"
1151        dportclose $worker
1152        return -1
1153    }
1154    dportclose $worker
1155   
1156    return 0
1157}
1158
1159proc portfile_test {this} {
1160    set receipt [registry_exists [$this get name]]
1161    if {$receipt != ""} {
1162        ui_debug "Found Dependency: receipt: $receipt"
1163        return 1
1164    } else {
1165        return 0
1166    }
1167}
1168
1169proc portfile_search_path {depregex search_path} {
1170    set found 0
1171    foreach path $search_path {
1172        if {![file isdirectory $path]} {
1173            continue
1174        }
1175        foreach filename [readdir $path] {
1176            if {[regexp $depregex $filename] == 1} {
1177                ui_debug "Found Dependency: path: $path filename: $filename regex: $depregex"
1178                set found 1
1179                break
1180            }
1181        }
1182    }
1183    return $found
1184}
1185
1186
1187
1188##### lib portfile depspec subclass #####
1189# Search registry, then library path for regex
1190global libportfile_vtbl
1191array set libportfile_vtbl [array get portfile_vtbl]
1192set libportfile_vtbl(test) libportfile_test
1193
1194proc libportfile_new {name match} {
1195    set obj [portfile_new $name]
1196   
1197    $obj set _vtbl libportfile_vtbl
1198    $obj set depregex $match
1199   
1200    return $obj
1201}
1202
1203# XXX - Architecture specific
1204# XXX - Rely on information from internal defines in cctools/dyld:
1205# define DEFAULT_FALLBACK_FRAMEWORK_PATH
1206# /Library/Frameworks:/Library/Frameworks:/Network/Library/Frameworks:/System/Library/Frameworks
1207# define DEFAULT_FALLBACK_LIBRARY_PATH /lib:/usr/local/lib:/lib:/usr/lib
1208# Environment variables DYLD_FRAMEWORK_PATH, DYLD_LIBRARY_PATH,
1209# DYLD_FALLBACK_FRAMEWORK_PATH, and DYLD_FALLBACK_LIBRARY_PATH take precedence
1210
1211proc libportfile_test {this} {
1212    global env prefix
1213   
1214    # Check the registry first
1215    set result [portfile_test $this]
1216    if {$result == 1} {
1217        return $result
1218    } else {
1219        # Not in the registry, check the library path.
1220        set depregex [$this get depregex]
1221       
1222        if {[info exists env(DYLD_FRAMEWORK_PATH)]} {
1223            lappend search_path $env(DYLD_FRAMEWORK_PATH)
1224        } else {
1225            lappend search_path /Library/Frameworks /Network/Library/Frameworks /System/Library/Frameworks
1226        }
1227        if {[info exists env(DYLD_FALLBACK_FRAMEWORK_PATH)]} {
1228            lappend search_path $env(DYLD_FALLBACK_FRAMEWORK_PATH)
1229        }
1230        if {[info exists env(DYLD_LIBRARY_PATH)]} {
1231            lappend search_path $env(DYLD_LIBRARY_PATH)
1232        } else {
1233            lappend search_path /lib /usr/local/lib /lib /usr/lib /op/local/lib /usr/X11R6/lib ${prefix}/lib
1234        }
1235        if {[info exists env(DYLD_FALLBACK_LIBRARY_PATH)]} {
1236            lappend search_path $env(DYLD_LIBRARY_PATH)
1237        }
1238        regsub {\.} $depregex {\.} depregex
1239        set depregex \^$depregex.*\\.dylib\$
1240       
1241        return [portfile_search_path $depregex $search_path]
1242    }
1243}
1244
1245##### bin portfile depspec subclass #####
1246# Search registry, then binary path for regex
1247global binportfile_vtbl
1248array set binportfile_vtbl [array get portfile_vtbl]
1249set binportfile_vtbl(test) binportfile_test
1250
1251proc binportfile_new {name match} {
1252    set obj [portfile_new $name]
1253   
1254    $obj set _vtbl binportfile_vtbl
1255    $obj set depregex $match
1256   
1257    return $obj
1258}
1259
1260proc binportfile_test {this} {
1261    global env prefix
1262   
1263    # Check the registry first
1264    set result [portfile_test $this]
1265    if {$result == 1} {
1266        return $result
1267    } else {
1268        # Not in the registry, check the binary path.
1269        set depregex [$this get depregex]
1270       
1271        set search_path [split $env(PATH) :]
1272       
1273        set depregex \^$depregex\$
1274       
1275        return [portfile_search_path $depregex $search_path]
1276    }
1277}
1278
1279##### path portfile depspec subclass #####
1280# Search registry, then search specified absolute or
1281# ${prefix} relative path for regex
1282global pathportfile_vtbl
1283array set pathportfile_vtbl [array get portfile_vtbl]
1284set pathportfile_vtbl(test) pathportfile_test
1285
1286proc pathportfile_new {name match} {
1287    set obj [portfile_new $name]
1288   
1289    $obj set _vtbl pathportfile_vtbl
1290    $obj set depregex $match
1291    return $obj
1292}
1293
1294proc pathportfile_test {this} {
1295    global env prefix
1296   
1297    # Check the registry first
1298    set result [portfile_test $this]
1299    if {$result == 1} {
1300        return $result
1301    } else {
1302        # Not in the registry, check the path.
1303        # separate directory from regex
1304        set fullname [$this get depregex]
1305
1306        regexp {^(.*)/(.*?)$} "$fullname" match search_path depregex
1307
1308        if {[string index $search_path 0] != "/"} {
1309                # Prepend prefix if not an absolute path
1310                set search_path "${prefix}/${search_path}"
1311        }
1312               
1313        set depregex \^$depregex\$
1314       
1315        return [portfile_search_path $depregex $search_path]
1316    }
1317}
1318
1319proc adduser {name args} {
1320    global os.platform
1321    set passwd {\*}
1322    set uid [nextuid]
1323    set gid [existsgroup nogroup]
1324    set realname ${name}
1325    set home /dev/null
1326    set shell /dev/null
1327
1328    foreach arg $args {
1329        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
1330            regsub -all " " ${val} "\\ " val
1331            set $key $val
1332        }
1333    }
1334
1335    if {[existsuser ${name}] != 0 || [existsuser ${uid}] != 0} {
1336        return
1337    }
1338
1339    if {${os.platform} == "darwin"} {
1340        system "niutil -create . /users/${name}"
1341        system "niutil -createprop . /users/${name} name ${name}"
1342        system "niutil -createprop . /users/${name} passwd ${passwd}"
1343        system "niutil -createprop . /users/${name} uid ${uid}"
1344        system "niutil -createprop . /users/${name} gid ${gid}"
1345        system "niutil -createprop . /users/${name} realname ${realname}"
1346        system "niutil -createprop . /users/${name} home ${home}"
1347        system "niutil -createprop . /users/${name} shell ${shell}"
1348    } else {
1349        # XXX adduser is only available for darwin, add more support here
1350        ui_warn "WARNING: adduser is not implemented on ${os.platform}."
1351        ui_warn "The requested user was not created."
1352    }
1353}
1354
1355proc addgroup {name args} {
1356    global os.platform
1357    set gid [nextgid]
1358    set passwd {\*}
1359    set users ""
1360
1361    foreach arg $args {
1362        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
1363            regsub -all " " ${val} "\\ " val
1364            set $key $val
1365        }
1366    }
1367
1368    if {[existsgroup ${name}] != 0 || [existsgroup ${gid}] != 0} {
1369        return
1370    }
1371
1372    if {${os.platform} == "darwin"} {
1373        system "niutil -create . /groups/${name}"
1374        system "niutil -createprop . /groups/${name} name ${name}"
1375        system "niutil -createprop . /groups/${name} gid ${gid}"
1376        system "niutil -createprop . /groups/${name} passwd ${passwd}"
1377        system "niutil -createprop . /groups/${name} users ${users}"
1378    } else {
1379        # XXX addgroup is only available for darwin, add more support here
1380        ui_warn "WARNING: addgroup is not implemented on ${os.platform}."
1381        ui_warn "The requested group was not created."
1382    }
1383}
Note: See TracBrowser for help on using the repository browser.