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

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

Handle deprecated options with no replacement

  • 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 \[set \$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        # XXX munge target. install really means registry, then install
603        # If more than one target ever needs this, make this a generic interface
604        if {$target == "install"} {
605            set target registry
606        }
607        set matches [depspec_get_matches $dlist provides $target]
608        if {[llength $matches] > 0} {
609            set dlist [dlist_append_dependents $dlist [lindex $matches 0] [list]]
610            # Special-case 'all'
611        } elseif {$target != "all"} {
612            ui_info "unknown target: $target"
613            return 1
614        }
615    }
616   
617    # Restore the state from a previous run.
618    set target_state_fd [open_statefile]
619   
620    set ret [dlist_evaluate $dlist generic_get_next]
621   
622    close $target_state_fd
623    return $ret
624}
625
626# returns the names of dependents of <name> from the <itemlist>
627proc dlist_append_dependents {dlist obj result} {
628   
629    # Append the item to the list, avoiding duplicates
630    if {[lsearch $result $obj] == -1} {
631        lappend result $obj
632    }
633   
634    # Recursively append any hard dependencies
635    foreach dep [$obj get requires] {
636        foreach provider [depspec_get_matches $dlist provides $dep] {
637            set result [dlist_append_dependents $dlist $provider $result]
638        }
639    }
640    # XXX: add soft-dependencies?
641    return $result
642}
643
644# open_statefile
645# open file to store name of completed targets
646proc open_statefile {args} {
647    global workpath portname
648   
649    if ![file isdirectory $workpath ] {
650        file mkdir $workpath
651    }
652    # flock Portfile
653    set statefile [file join $workpath .darwinports.${portname}.state]
654    if {[file exists $statefile] && ![file writable $statefile]} {
655        return -code error "$statefile is not writable - check permission on port directory"
656    }
657    set fd [open $statefile a+]
658    if [catch {flock $fd -exclusive -noblock} result] {
659        if {"$result" == "EAGAIN"} {
660            ui_msg "Waiting for lock on $statefile"
661        } elseif {"$result" == "EOPNOTSUPP"} {
662            # Locking not supported, just return
663            return $fd
664        } else {
665            return -code error "$result obtaining lock on $statefile"
666        }
667    }
668    flock $fd -exclusive
669    return $fd
670}
671
672# check_statefile
673# Check completed/selected state of target/variant $name
674proc check_statefile {class name fd} {
675    global portpath workdir
676   
677    seek $fd 0
678    while {[gets $fd line] >= 0} {
679                if {$line == "$class: $name"} {
680                        return 1
681                }
682    }
683    return 0
684}
685
686# write_statefile
687# Set target $name completed in the state file
688proc write_statefile {class name fd} {
689    if {[check_statefile $class $name $fd]} {
690                return 0
691    }
692    seek $fd 0 end
693    puts $fd "$class: $name"
694    flush $fd
695}
696
697# check_statefile_variants
698# Check that recorded selection of variants match the current selection
699proc check_statefile_variants {variations fd} {
700        upvar $variations upvariations
701       
702    seek $fd 0
703    while {[gets $fd line] >= 0} {
704                if {[regexp "variant: (.*)" $line match name]} {
705                        set oldvariations([string range $name 1 end]) [string range $name 0 0]
706                }
707    }
708
709        set mismatch 0
710        if {[array size oldvariations] > 0} {
711                if {[array size oldvariations] != [array size upvariations]} {
712                        set mismatch 1
713                } else {
714                        foreach key [array names upvariations *] {
715                                if {$upvariations($key) != $oldvariations($key)} {
716                                        set mismatch 1
717                                        break
718                                }
719                        }
720                }
721        }
722
723        return $mismatch
724}
725
726# Traverse the ports collection hierarchy and call procedure func for
727# each directory containing a Portfile
728proc port_traverse {func {dir .}} {
729    set pwd [pwd]
730    if [catch {cd $dir} err] {
731        ui_error $err
732        return
733    }
734    foreach name [readdir .] {
735        if {[string match $name .] || [string match $name ..]} {
736            continue
737        }
738        if [file isdirectory $name] {
739            port_traverse $func $name
740        } else {
741            if [string match $name Portfile] {
742                catch {eval $func {[file join $pwd $dir]}}
743            }
744        }
745    }
746    cd $pwd
747}
748
749
750########### Port Variants ###########
751
752# Each variant which provides a subset of the requested variations
753# will be chosen.  Returns a list of the selected variants.
754proc choose_variants {dlist variations} {
755    upvar $variations upvariations
756   
757    set selected [list]
758   
759    foreach obj $dlist {
760        # Enumerate through the provides, tallying the pros and cons.
761        set pros 0
762        set cons 0
763        set ignored 0
764        foreach flavor [$obj get provides] {
765            if {[info exists upvariations($flavor)]} {
766                if {$upvariations($flavor) == "+"} {
767                    incr pros
768                } elseif {$upvariations($flavor) == "-"} {
769                    incr cons
770                }
771            } else {
772                incr ignored
773            }
774        }
775       
776        if {$cons > 0} { continue }
777       
778        if {$pros > 0 && $ignored == 0} {
779            lappend selected $obj
780        }
781    }
782    return $selected
783}
784
785proc variant_run {this} {
786    set name [$this get name]
787    ui_debug "Executing $name provides [$this get provides]"
788
789        # test for conflicting variants
790        foreach v [$this get conflicts] {
791                if {[variant_isset $v]} {
792                        ui_error "Variant $name conflicts with $v"
793                        return 1
794                }
795        }
796
797    # execute proc with same name as variant.
798    if {[catch "variant-${name}" result]} {
799        ui_error "Error executing $name: $result"
800        return 1
801    }
802    return 0
803}
804
805proc eval_variants {variations target} {
806    global all_variants ports_force
807    set dlist $all_variants
808        set result 0
809    upvar $variations upvariations
810    set chosen [choose_variants $dlist upvariations]
811   
812    # now that we've selected variants, change all provides [a b c] to [a-b-c]
813    # this will eliminate ambiguity between item a, b, and a-b while fulfilling requirments.
814    #foreach obj $dlist {
815    #    $obj set provides [list [join [$obj get provides] -]]
816    #}
817   
818    set newlist [list]
819    foreach variant $chosen {
820        set newlist [dlist_append_dependents $dlist $variant $newlist]
821    }
822   
823    dlist_evaluate $newlist generic_get_next
824       
825        # Make sure the variations match those stored in the statefile.
826        # If they don't match, print an error indicating a 'port clean'
827        # should be performed. 
828        # - Skip this test if the statefile is empty.
829        # - Skip this test if performing a clean.
830        # - Skip this test if ports_force was specified.
831
832        if {$target != "clean" && 
833                !([info exists ports_force] && $ports_force == "yes")} {
834                set state_fd [open_statefile]
835       
836                if {[check_statefile_variants upvariations $state_fd]} {
837                        ui_error "Requested variants do not match original selection.\nPlease perform 'port clean' or specify the force option."
838                        set result 1
839                } else {
840                        # Write variations out to the statefile
841                        foreach key [array names upvariations *] {
842                                write_statefile variant $upvariations($key)$key $state_fd
843                        }
844                }
845               
846                close $state_fd
847        }
848       
849        return $result
850}
851
852##### DEPSPEC #####
853
854# Object-Oriented Depspecs
855#
856# Each depspec will have its data stored in an array
857# (indexed by field name) and its procedures will be
858# called via the dispatch procedure that is returned
859# from depspec_new.
860#
861# sample usage:
862# set obj [depspec_new]
863# $obj set name "hello"
864#
865
866# Depspec
867#       str name
868#       str provides[]
869#       str requires[]
870#       str uses[]
871
872global depspec_uniqid
873set depspec_uniqid 0
874
875# Depspec class definition.
876global depspec_vtbl
877set depspec_vtbl(test) depspec_test
878set depspec_vtbl(run) depspec_run
879set depspec_vtbl(get) depspec_get
880set depspec_vtbl(set) depspec_set
881set depspec_vtbl(has) depspec_has
882set depspec_vtbl(append) depspec_append
883
884# constructor for abstract depspec class
885proc depspec_new {name} {
886    global depspec_uniqid
887    set id [incr depspec_uniqid]
888   
889    # declare the array of data
890    set data dpspc_data_${id}
891    set disp dpspc_disp_${id}
892   
893    global $data 
894    set ${data}(name) $name
895    set ${data}(_vtbl) depspec_vtbl
896   
897    eval "proc $disp {method args} { \n \
898                        global $data \n \
899                        eval return \\\[depspec_dispatch $disp $data \$method \$args\\\] \n \
900                }"
901   
902    return $disp
903}
904
905proc depspec_get {this prop} {
906    set data [$this _data]
907    global $data
908    if {[eval info exists ${data}($prop)]} {
909        eval return $${data}($prop)
910    } else {
911        return ""
912    }
913}
914
915proc depspec_set {this prop args} {
916    set data [$this _data]
917    global $data
918    eval "set ${data}($prop) \"$args\""
919}
920
921proc depspec_has {this prop} {
922    set data [$this _data]
923    global $data
924    eval return \[info exists ${data}($prop)\]
925}
926
927proc depspec_append {this prop args} {
928    set data [$this _data]
929    global $data
930    set vals [join $args " "]
931    eval lappend ${data}($prop) $vals
932}
933
934# is the only proc to get direct access to the object's data
935# so the _data accessor has to be defined here.  all other
936# methods are looked up in the virtual function table,
937# and are called with {$this $args}.
938proc depspec_dispatch {this data method args} {
939    global $data
940    if {$method == "_data"} { return $data }
941    eval set vtbl $${data}(_vtbl)
942    global $vtbl
943    if {[info exists ${vtbl}($method)]} {
944        eval set function $${vtbl}($method)
945        eval "return \[$function $this $args\]"
946    } else {
947        ui_error "unknown method: $method"
948    }
949    return ""
950}
951
952proc depspec_test {this} {
953    return 0
954}
955
956proc depspec_run {this} {
957    return 0
958}
959
960##### target depspec subclass #####
961
962# Target class definition.
963global target_vtbl
964array set target_vtbl [array get depspec_vtbl]
965set target_vtbl(run) target_run
966set target_vtbl(provides) target_provides
967set target_vtbl(requires) target_requires
968set target_vtbl(uses) target_uses
969set target_vtbl(deplist) target_deplist
970set target_vtbl(prerun) target_prerun
971set target_vtbl(postrun) target_postrun
972
973# constructor for target depspec class
974proc target_new {name procedure} {
975    global targets
976    set obj [depspec_new $name]
977   
978    $obj set _vtbl target_vtbl
979    $obj set procedure $procedure
980   
981    lappend targets $obj
982   
983    return $obj
984}
985
986proc target_provides {this args} {
987    global targets
988    # Register the pre-/post- hooks for use in Portfile.
989    # Portfile syntax: pre-fetch { puts "hello world" }
990    # User-code exceptions are caught and returned as a result of the target.
991    # Thus if the user code breaks, dependent targets will not execute.
992    foreach target $args {
993        set origproc [$this get procedure]
994        set ident [$this get name]
995        if {[info commands $target] != ""} {
996            ui_debug "[$this get name] registered provides \'$target\', a pre-existing procedure. Target override will not be provided"
997        } else {
998                eval "proc $target {args} \{ \n\
999                        $this set procedure proc-${ident}-${target}
1000                        eval \"proc proc-${ident}-${target} \{name\} \{ \n\
1001                                if \{\\\[catch userproc-${ident}-${target} result\\\]\} \{ \n\
1002                                        return -code error \\\$result \n\
1003                                \} else \{ \n\
1004                                        return 0 \n\
1005                                \} \n\
1006                        \}\" \n\
1007                        eval \"proc do-$target \{\} \{ $origproc $target\}\" \n\
1008                        makeuserproc userproc-${ident}-${target} \$args \n\
1009                \}"
1010        }
1011        eval "proc pre-$target {args} \{ \n\
1012                        $this append pre proc-pre-${ident}-${target}
1013                        eval \"proc proc-pre-${ident}-${target} \{name\} \{ \n\
1014                                if \{\\\[catch userproc-pre-${ident}-${target} result\\\]\} \{ \n\
1015                                        return -code error \\\$result \n\
1016                                \} else \{ \n\
1017                                        return 0 \n\
1018                                \} \n\
1019                        \}\" \n\
1020                        makeuserproc userproc-pre-${ident}-${target} \$args \n\
1021                \}"
1022        eval "proc post-$target {args} \{ \n\
1023                        $this append post proc-post-${ident}-${target}
1024                        eval \"proc proc-post-${ident}-${target} \{name\} \{ \n\
1025                                if \{\\\[catch userproc-post-${ident}-${target} result\\\]\} \{ \n\
1026                                        return -code error \\\$result \n\
1027                                \} else \{ \n\
1028                                        return 0 \n\
1029                                \} \n\
1030                        \}\" \n\
1031                        makeuserproc userproc-post-${ident}-${target} \$args \n\
1032                \}"
1033    }
1034    eval "depspec_append $this provides $args"
1035}
1036
1037proc target_requires {this args} {
1038    eval "depspec_append $this requires $args"
1039}
1040
1041proc target_uses {this args} {
1042    eval "depspec_append $this uses $args"
1043}
1044
1045proc target_deplist {this args} {
1046    eval "depspec_append $this deplist $args"
1047}
1048
1049proc target_prerun {this args} {
1050    eval "depspec_append $this prerun $args"
1051}
1052
1053proc target_postrun {this args} {
1054    eval "depspec_append $this postrun $args"
1055}
1056
1057##### variant depspec subclass #####
1058
1059# Variant class definition.
1060global variant_vtbl
1061array set variant_vtbl [array get depspec_vtbl]
1062set variant_vtbl(run) variant_run
1063
1064# constructor for target depspec class
1065proc variant_new {name} {
1066    set obj [depspec_new $name]
1067   
1068    $obj set _vtbl variant_vtbl
1069   
1070    return $obj
1071}
1072
1073proc handle_default_variants {option action args} {
1074    global variations
1075    switch -regex $action {
1076        set|append {
1077            foreach v $args {
1078                if {[regexp {([-+])([-A-Za-z0-9_]+)} $v whole val variant]} {
1079                    if {![info exists variations($variant)]} {
1080                        set variations($variant) $val
1081                    }
1082                }
1083            }
1084        }
1085        delete {
1086            # xxx
1087        }
1088    }
1089}
1090
1091##### portfile depspec subclass #####
1092global portfile_vtbl
1093array set portfile_vtbl [array get depspec_vtbl]
1094set portfile_vtbl(run) portfile_run
1095set portfile_vtbl(test) portfile_test
1096
1097proc portfile_new {name} {
1098    set obj [depspec_new $name]
1099   
1100    $obj set _vtbl portfile_vtbl
1101   
1102    return $obj
1103}
1104
1105# portfile primitive that calls portexec_int with newworkpath == ${workpath}
1106proc portexec {portname target} {
1107        global workpath
1108        portexec_int $portname $target $workpath
1109}
1110
1111# build the specified portfile with default workpath
1112proc portfile_run {this} {
1113    set portname [$this get name]
1114    if {![catch {portexec_int $portname install} result]} {
1115                portexec_int $portname clean
1116    }
1117    return $result
1118}
1119
1120# builds the specified port (looked up in the index) to the specified target
1121# doesn't yet support options or variants...
1122# newworkpath defines the port's workpath - useful for when one port relies
1123# on the source, etc, of another
1124proc portexec_int {portname target {newworkpath ""}} {
1125    ui_debug "Executing $target ($portname)"
1126    set variations [list]
1127    if {$newworkpath == ""} {
1128        array set options [list]
1129    } else {
1130        set options(workpath) ${newworkpath}
1131    }
1132        # Escape regex special characters
1133        regsub -all "(\\(){1}|(\\)){1}|(\\{1}){1}|(\\+){1}|(\\{1}){1}|(\\{){1}|(\\}){1}|(\\^){1}|(\\$){1}|(\\.){1}|(\\\\){1}" $portname "\\\\&" search_string
1134
1135    set res [dportsearch ^$search_string\$]
1136    if {[llength $res] < 2} {
1137        ui_error "Dependency $portname not found"
1138        return -1
1139    }
1140
1141    array set portinfo [lindex $res 1]
1142    set porturl $portinfo(porturl)
1143    set worker [dportopen $porturl [array get options] $variations]
1144    if {[catch {dportexec $worker $target} result] || $result != 0} {
1145        ui_error "Execution $portname $target failed: $result"
1146        dportclose $worker
1147        return -1
1148    }
1149    dportclose $worker
1150   
1151    return 0
1152}
1153
1154proc portfile_test {this} {
1155    set receipt [registry_exists [$this get name]]
1156    if {$receipt != ""} {
1157        ui_debug "Found Dependency: receipt: $receipt"
1158        return 1
1159    } else {
1160        return 0
1161    }
1162}
1163
1164proc portfile_search_path {depregex search_path} {
1165    set found 0
1166    foreach path $search_path {
1167        if {![file isdirectory $path]} {
1168            continue
1169        }
1170        foreach filename [readdir $path] {
1171            if {[regexp $depregex $filename] == 1} {
1172                ui_debug "Found Dependency: path: $path filename: $filename regex: $depregex"
1173                set found 1
1174                break
1175            }
1176        }
1177    }
1178    return $found
1179}
1180
1181
1182
1183##### lib portfile depspec subclass #####
1184# Search registry, then library path for regex
1185global libportfile_vtbl
1186array set libportfile_vtbl [array get portfile_vtbl]
1187set libportfile_vtbl(test) libportfile_test
1188
1189proc libportfile_new {name match} {
1190    set obj [portfile_new $name]
1191   
1192    $obj set _vtbl libportfile_vtbl
1193    $obj set depregex $match
1194   
1195    return $obj
1196}
1197
1198# XXX - Architecture specific
1199# XXX - Rely on information from internal defines in cctools/dyld:
1200# define DEFAULT_FALLBACK_FRAMEWORK_PATH
1201# /Library/Frameworks:/Library/Frameworks:/Network/Library/Frameworks:/System/Library/Frameworks
1202# define DEFAULT_FALLBACK_LIBRARY_PATH /lib:/usr/local/lib:/lib:/usr/lib
1203# Environment variables DYLD_FRAMEWORK_PATH, DYLD_LIBRARY_PATH,
1204# DYLD_FALLBACK_FRAMEWORK_PATH, and DYLD_FALLBACK_LIBRARY_PATH take precedence
1205
1206proc libportfile_test {this} {
1207    global env prefix
1208   
1209    # Check the registry first
1210    set result [portfile_test $this]
1211    if {$result == 1} {
1212        return $result
1213    } else {
1214        # Not in the registry, check the library path.
1215        set depregex [$this get depregex]
1216       
1217        if {[info exists env(DYLD_FRAMEWORK_PATH)]} {
1218            lappend search_path $env(DYLD_FRAMEWORK_PATH)
1219        } else {
1220            lappend search_path /Library/Frameworks /Network/Library/Frameworks /System/Library/Frameworks
1221        }
1222        if {[info exists env(DYLD_FALLBACK_FRAMEWORK_PATH)]} {
1223            lappend search_path $env(DYLD_FALLBACK_FRAMEWORK_PATH)
1224        }
1225        if {[info exists env(DYLD_LIBRARY_PATH)]} {
1226            lappend search_path $env(DYLD_LIBRARY_PATH)
1227        } else {
1228            lappend search_path /lib /usr/local/lib /lib /usr/lib /op/local/lib /usr/X11R6/lib ${prefix}/lib
1229        }
1230        if {[info exists env(DYLD_FALLBACK_LIBRARY_PATH)]} {
1231            lappend search_path $env(DYLD_LIBRARY_PATH)
1232        }
1233        regsub {\.} $depregex {\.} depregex
1234        set depregex \^$depregex.*\\.dylib\$
1235       
1236        return [portfile_search_path $depregex $search_path]
1237    }
1238}
1239
1240##### bin portfile depspec subclass #####
1241# Search registry, then binary path for regex
1242global binportfile_vtbl
1243array set binportfile_vtbl [array get portfile_vtbl]
1244set binportfile_vtbl(test) binportfile_test
1245
1246proc binportfile_new {name match} {
1247    set obj [portfile_new $name]
1248   
1249    $obj set _vtbl binportfile_vtbl
1250    $obj set depregex $match
1251   
1252    return $obj
1253}
1254
1255proc binportfile_test {this} {
1256    global env prefix
1257   
1258    # Check the registry first
1259    set result [portfile_test $this]
1260    if {$result == 1} {
1261        return $result
1262    } else {
1263        # Not in the registry, check the binary path.
1264        set depregex [$this get depregex]
1265       
1266        set search_path [split $env(PATH) :]
1267       
1268        set depregex \^$depregex\$
1269       
1270        return [portfile_search_path $depregex $search_path]
1271    }
1272}
1273
1274##### path portfile depspec subclass #####
1275# Search registry, then search specified absolute or
1276# ${prefix} relative path for regex
1277global pathportfile_vtbl
1278array set pathportfile_vtbl [array get portfile_vtbl]
1279set pathportfile_vtbl(test) pathportfile_test
1280
1281proc pathportfile_new {name match} {
1282    set obj [portfile_new $name]
1283   
1284    $obj set _vtbl pathportfile_vtbl
1285    $obj set depregex $match
1286    return $obj
1287}
1288
1289proc pathportfile_test {this} {
1290    global env prefix
1291   
1292    # Check the registry first
1293    set result [portfile_test $this]
1294    if {$result == 1} {
1295        return $result
1296    } else {
1297        # Not in the registry, check the path.
1298        # separate directory from regex
1299        set fullname [$this get depregex]
1300
1301        regexp {^(.*)/(.*?)$} "$fullname" match search_path depregex
1302
1303        if {[string index $search_path 0] != "/"} {
1304                # Prepend prefix if not an absolute path
1305                set search_path "${prefix}/${search_path}"
1306        }
1307               
1308        set depregex \^$depregex\$
1309       
1310        return [portfile_search_path $depregex $search_path]
1311    }
1312}
1313
1314proc adduser {name args} {
1315    global os.platform
1316    set passwd {\*}
1317    set uid [nextuid]
1318    set gid [existsgroup nogroup]
1319    set realname ${name}
1320    set home /dev/null
1321    set shell /dev/null
1322
1323    foreach arg $args {
1324        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
1325            regsub -all " " ${val} "\\ " val
1326            set $key $val
1327        }
1328    }
1329
1330    if {[existsuser ${name}] != 0 || [existsuser ${uid}] != 0} {
1331        return
1332    }
1333
1334    if {${os.platform} == "darwin"} {
1335        system "niutil -create . /users/${name}"
1336        system "niutil -createprop . /users/${name} name ${name}"
1337        system "niutil -createprop . /users/${name} passwd ${passwd}"
1338        system "niutil -createprop . /users/${name} uid ${uid}"
1339        system "niutil -createprop . /users/${name} gid ${gid}"
1340        system "niutil -createprop . /users/${name} realname ${realname}"
1341        system "niutil -createprop . /users/${name} home ${home}"
1342        system "niutil -createprop . /users/${name} shell ${shell}"
1343    } else {
1344        # XXX adduser is only available for darwin, add more support here
1345        ui_warn "WARNING: adduser is not implemented on ${os.platform}."
1346        ui_warn "The requested user was not created."
1347    }
1348}
1349
1350proc addgroup {name args} {
1351    global os.platform
1352    set gid [nextgid]
1353    set passwd {\*}
1354    set users ""
1355
1356    foreach arg $args {
1357        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
1358            regsub -all " " ${val} "\\ " val
1359            set $key $val
1360        }
1361    }
1362
1363    if {[existsgroup ${name}] != 0 || [existsgroup ${gid}] != 0} {
1364        return
1365    }
1366
1367    if {${os.platform} == "darwin"} {
1368        system "niutil -create . /groups/${name}"
1369        system "niutil -createprop . /groups/${name} name ${name}"
1370        system "niutil -createprop . /groups/${name} gid ${gid}"
1371        system "niutil -createprop . /groups/${name} passwd ${passwd}"
1372        system "niutil -createprop . /groups/${name} users ${users}"
1373    } else {
1374        # XXX addgroup is only available for darwin, add more support here
1375        ui_warn "WARNING: addgroup is not implemented on ${os.platform}."
1376        ui_warn "The requested group was not created."
1377    }
1378}
1379
1380proc x11prefix {args} {
1381    prefix /usr/X11R6
1382}
Note: See TracBrowser for help on using the repository browser.