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

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

Fix failure check and provide more useful output

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