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

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

Add option deprecation routines
Deprecate build.target.all and build.target.install
Add install command and default it off of build command
Update documentation to reflect option changes

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