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

Last change on this file since 3908 was 3908, checked in by fkr, 15 years ago

Bug:
Submitted by:
Reviewed by:
Approved by:
Obtained from:

grmpf. cleaning out a stale proc here.

  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 30.4 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 darwinports_dlist 1.0
35package require msgcat
36
37global targets target_uniqid all_variants
38
39set targets [list]
40set target_uniqid 0
41
42set all_variants [list]
43
44########### External High Level Procedures ###########
45
46
47# UI Instantiations
48foreach priority "debug info msg error warn" {
49    eval "proc ui_$priority {str} \{ \n\
50        set message(priority) $priority \n\
51        set message(data) \$str \n\
52        ui_event \[array get message\] \n\
53    \}"
54}
55
56
57namespace eval options {
58}
59
60# option
61# This is an accessor for Portfile options.  Targets may use
62# this in the same style as the standard Tcl "set" procedure.
63#       name  - the name of the option to read or write
64#       value - an optional value to assign to the option
65
66proc option {name args} {
67        # XXX: right now we just transparently use globals
68        # eventually this will need to bridge the options between
69        # the Portfile's interpreter and the target's interpreters.
70        global $name
71        if {[llength $args] > 0} {
72                ui_debug "setting option $name to $args"
73                set $name [lindex $args 0]
74        }
75        return [set $name]
76}
77
78# exists
79# This is an accessor for Portfile options.  Targets may use
80# this procedure to test for the existence of a Portfile option.
81#       name - the name of the option to test for existence
82
83proc exists {name} {
84        # XXX: right now we just transparently use globals
85        # eventually this will need to bridge the options between
86        # the Portfile's interpreter and the target's interpreters.
87        global $name
88        return [info exists $name]
89}
90
91# options
92# Exports options in an array as externally callable procedures
93# Thus, "options name date" would create procedures named "name"
94# and "date" that set global variables "name" and "date", respectively
95# When an option is modified in any way, options::$option is called,
96# if it exists
97# Arguments: <list of options>
98proc options {args} {
99    foreach option $args {
100        eval "proc $option {args} \{ \n\
101            global ${option} user_options option_procs \n\
102                \if \{!\[info exists user_options(${option})\]\} \{ \n\
103                     set ${option} \$args \n\
104                         if \{\[info exists option_procs($option)\]\} \{ \n\
105                                foreach p \$option_procs($option) \{ \n\
106                                        eval \"\$p $option set \$args\" \n\
107                                \} \n\
108                         \} \n\
109                \} \n\
110        \}"
111       
112        eval "proc ${option}-delete {args} \{ \n\
113            global ${option} user_options option_procs \n\
114                \if \{!\[info exists user_options(${option})\]\} \{ \n\
115                    foreach val \$args \{ \n\
116                        ldelete ${option} \$val \n\
117                    \} \n\
118                    if \{\[string length \$\{${option}\}\] == 0\} \{ \n\
119                        unset ${option} \n\
120                    \} \n\
121                        if \{\[info exists option_procs($option)\]\} \{ \n\
122                            foreach p \$option_procs($option) \{ \n\
123                                eval \"\$p $option delete \$args\" \n\
124                        \} \n\
125                    \} \n\
126                \} \n\
127        \}"
128        eval "proc ${option}-append {args} \{ \n\
129            global ${option} user_options option_procs \n\
130                \if \{!\[info exists user_options(${option})\]\} \{ \n\
131                    if \{\[info exists ${option}\]\} \{ \n\
132                        set ${option} \[concat \$\{$option\} \$args\] \n\
133                    \} else \{ \n\
134                        set ${option} \$args \n\
135                    \} \n\
136                    if \{\[info exists option_procs($option)\]\} \{ \n\
137                        foreach p \$option_procs($option) \{ \n\
138                            eval \"\$p $option append \$args\" \n\
139                        \} \n\
140                    \} \n\
141                \} \n\
142        \}"
143    }
144}
145
146proc options_export {args} {
147    foreach option $args {
148        eval "proc options::${option} \{args\} \{ \n\
149            global ${option} PortInfo \n\
150            if \{\[info exists ${option}\]\} \{ \n\
151                set PortInfo(${option}) \$${option} \n\
152            \} else \{ \n\
153                unset PortInfo(${option}) \n\
154            \} \n\
155        \}"
156        option_proc ${option} options::${option}
157    }
158}
159
160# option_deprecate
161# Causes a warning to be printed when an option is set or accessed
162proc option_deprecate {option {newoption ""} } {
163    # If a new option is specified, default the option to {${newoption}}
164    # Display a warning
165    if {$newoption != ""} {
166        eval "proc warn_deprecated_$option \{option action args\} \{ \n\
167            global portname $option $newoption \n\
168            if \{\$action != \"read\"\} \{ \n\
169                $newoption \$$option \n\
170            \} else \{ \n\
171                ui_warn \"Port \$portname using deprecated option \\\"$option\\\".\" \n\
172                $option \[set $newoption\] \n\
173            \} \n\
174        \}"
175    } else {
176        eval "proc warn_deprecated_$option \{option action args\} \{ \n\
177            global portname $option $newoption \n\
178            ui_warn \"Port \$portname using deprecated option \\\"$option\\\".\" \n\
179        \}"
180    }
181    option_proc $option warn_deprecated_$option
182}
183
184proc option_proc {option args} {
185    global option_procs $option
186    eval "lappend option_procs($option) $args"
187    # Add a read trace to the variable, as the option procedures have no access to reads
188    trace variable $option r option_proc_trace
189}
190
191# option_proc_trace
192# trace handler for option reads. Calls option procedures with correct arguments.
193proc option_proc_trace {optionName index op} {
194    global option_procs
195    foreach p $option_procs($optionName) {
196        eval "$p $optionName read"
197    }
198}
199
200# commands
201# Accepts a list of arguments, of which several options are created
202# and used to form a standard set of command options.
203proc commands {args} {
204    foreach option $args {
205        options use_${option} ${option}.dir ${option}.pre_args ${option}.args ${option}.post_args ${option}.env ${option}.type ${option}.cmd
206    }
207}
208
209# command
210# Given a command name, command assembled a string
211# composed of the command options.
212proc command {command} {
213    global ${command}.dir ${command}.pre_args ${command}.args ${command}.post_args ${command}.env ${command}.type ${command}.cmd
214   
215    set cmdstring ""
216    if {[info exists ${command}.dir]} {
217        set cmdstring "cd \"[set ${command}.dir]\" &&"
218    }
219   
220    if {[info exists ${command}.env]} {
221        foreach string [set ${command}.env] {
222            set cmdstring "$cmdstring $string"
223        }
224    }
225   
226    if {[info exists ${command}.cmd]} {
227        foreach string [set ${command}.cmd] {
228            set cmdstring "$cmdstring $string"
229        }
230    } else {
231        set cmdstring "$cmdstring ${command}"
232    }
233    foreach var "${command}.pre_args ${command}.args ${command}.post_args" {
234        if {[info exists $var]} {
235            foreach string [set ${var}] {
236                set cmdstring "$cmdstring $string"
237            }
238        }
239    }
240    ui_debug "Assembled command: '$cmdstring'"
241    return $cmdstring
242}
243
244# default
245# Sets a variable to the supplied default if it does not exist,
246# and adds a variable trace. The variable traces allows for delayed
247# variable and command expansion in the variable's default value.
248proc default {option val} {
249    global $option option_defaults
250    if {[info exists option_defaults($option)]} {
251        ui_debug "Re-registering default for $option"
252    } else {
253        # If option is already set and we did not set it
254        # do not reset the value
255        if {[info exists $option]} {
256            return
257        }
258    }
259    set option_defaults($option) $val
260    set $option $val
261    trace variable $option rwu default_check
262}
263
264# default_check
265# trace handler to provide delayed variable & command expansion
266# for default variable values
267proc default_check {optionName index op} {
268    global option_defaults $optionName
269    switch $op {
270        w {
271            unset option_defaults($optionName)
272            trace vdelete $optionName rwu default_check
273            return
274        }
275        r {
276            upvar $optionName option
277            uplevel #0 set $optionName $option_defaults($optionName)
278            return
279        }
280        u {
281            unset option_defaults($optionName)
282            trace vdelete $optionName rwu default_check
283            return
284        }
285    }
286}
287
288# variant <provides> [<provides> ...] [requires <requires> [<requires>]]
289# Portfile level procedure to provide support for declaring variants
290proc variant {args} {
291    global all_variants PortInfo
292    upvar $args upargs
293   
294    set len [llength $args]
295    set code [lindex $args end]
296    set args [lrange $args 0 [expr $len - 2]]
297   
298    set ditem [variant_new "temp-variant"]
299   
300    # mode indicates what the arg is interpreted as.
301        # possible mode keywords are: requires, conflicts, provides
302        # The default mode is provides.  Arguments are added to the
303        # most recently specified mode (left to right).
304    set mode "provides"
305    foreach arg $args {
306                switch -exact $arg {
307                        provides { set mode "provides" }
308                        requires { set mode "requires" }
309                        conflicts { set mode "conflicts" }
310                        default { ditem_append $ditem $mode $arg }             
311        }
312    }
313    ditem_key $ditem name "[join [ditem_key $ditem provides] -]"
314
315    # make a user procedure named variant-blah-blah
316    # we will call this procedure during variant-run
317    makeuserproc "variant-[ditem_key $ditem name]" \{$code\}
318    lappend all_variants $ditem
319   
320    # Export provided variant to PortInfo
321    lappend PortInfo(variants) [ditem_key $ditem provides]
322}
323
324# variant_isset name
325# Returns 1 if variant name selected, otherwise 0
326proc variant_isset {name} {
327    global variations
328   
329    if {[info exists variations($name)] && $variations($name) == "+"} {
330        return 1
331    }
332    return 0
333}
334
335# variant_set name
336# Sets variant to run for current portfile
337proc variant_set {name} {
338    global variations
339   
340    set variations($name) +
341}
342
343# variant_unset name
344# Clear variant for current portfile
345proc variant_unset {name} {
346    global variations
347
348    set variations($name) -
349}
350
351# platform <os> [<release>] [<arch>]
352# Portfile level procedure to provide support for declaring platform-specifics
353# Basically, just wrap 'variant', so that Portfiles' platform declarations can
354# be more readable, and support arch and version specifics
355proc platform {args} {
356        global all_variants PortInfo os.platform os.arch os.version
357        upvar $args upargs
358
359        set len [llength $args]
360        set code [lindex $args end]
361        set os [lindex $args 0]
362        set args [lrange $args 1 [expr $len - 2]]
363       
364        set ditem [variant_new "temp-variant"]
365
366        foreach arg $args {
367                if {[regexp {(^[0-9]$)} $arg match result]} {
368                        set release $result
369                } elseif {[regexp {([a-zA-Z0-9]*)} $arg match result]} {
370                        set arch $result
371                }
372        }
373
374        # Add the variant for this platform
375        set platform $os
376        if {[info exists release]} { set platform ${platform}_${release} }
377        if {[info exists arch]} { set platform ${platform}_${arch} }
378
379        variant $platform $code
380
381        # Set the variant if this platform matches the platform we're on
382        if {[info exists os.platform] && ${os.platform} == $os} { 
383                set sel_platform $os
384                if {[info exists os.version] && [info exists release]} {
385                        regexp {([0-9]*)[0-9\.]?} ${os.version} match major
386                        if {$major == $release } { 
387                                set sel_platform ${sel_platform}_${release} 
388                        }
389                }
390                if {[info exists os.arch] && [info exists arch] && ${os.arch} == $arch} {
391                        set sel_platform $arch
392                }
393                variant_set $sel_platform
394        }
395       
396}
397
398########### Misc Utility Functions ###########
399
400# tbool (testbool)
401# If the variable exists in the calling procedure's namespace
402# and is set to "yes", return 1. Otherwise, return 0
403proc tbool {key} {
404    upvar $key $key
405    if {[info exists $key]} {
406        if {[string equal -nocase [set $key] "yes"]} {
407            return 1
408        }
409    }
410    return 0
411}
412
413# ldelete
414# Deletes a value from the supplied list
415proc ldelete {list value} {
416    upvar $list uplist
417    set ix [lsearch -exact $uplist $value]
418    if {$ix >= 0} {
419        set uplist [lreplace $uplist $ix $ix]
420    }
421}
422
423# reinplace
424# Provides "sed in place" functionality
425proc reinplace {pattern args}  {
426    if {$args == ""} {
427        ui_error "reinplace: no value given for parameter \"file\""
428        return -code error "no value given for parameter \"file\" to \"reinplace\"" 
429    }
430
431    foreach file $args {
432        if {[catch {set tmpfile [mkstemp "/tmp/[file tail $file].sed.XXXXXXXX"]} error]} {
433            ui_error "reinplace: $error"
434            return -code error "reinplace failed"
435        } else {
436            # Extract the Tcl Channel number
437            set tmpfd [lindex $tmpfile 0]
438            # Set tmpfile to only the file name
439            set tmpfile [lindex $tmpfile 1]
440        }
441
442        if {[catch {exec sed $pattern < $file >@ $tmpfd} error]} {
443            ui_error "reinplace: $error"
444            file delete "$tmpfile"
445            return -code error "reinplace failed"
446        }
447
448        close $tmpfd
449
450        set attributes [file attributes $file]
451        # We need to overwrite this file
452        if {[catch {file attributes $file -permissions u+w} error]} {
453            ui_error "reinplace: $error"
454            file delete "$tmpfile"
455            return -code error "reinplace failed"
456        }
457
458        if {[catch {exec cp $tmpfile $file} error]} {
459            ui_error "reinplace: $error"
460            file delete "$tmpfile"
461            return -code error "reinplace failed"
462        }
463       
464        for {set i 0} {$i < [llength attributes]} {incr i} {
465            set opt [lindex $attributes $i]
466            incr i
467            set arg [lindex $attributes $i]
468            file attributes $file $opt $arg
469        }
470       
471        file delete "$tmpfile"
472    }
473    return
474}
475
476# filefindbypath
477# Provides searching of the standard path for included files
478proc filefindbypath {fname} {
479    global distpath filedir workdir worksrcdir portpath
480
481    if {[file readable $portpath/$fname]} {
482        return $portpath/$fname
483    } elseif {[file readable $portpath/$filedir/$fname]} {
484        return $portpath/$filedir/$fname
485    } elseif {[file readable $distpath/$fname]} {
486        return $distpath/$fname
487    }
488    return ""
489}
490
491# include
492# Source a file, looking for it along a standard search path.
493proc include {fname} {
494    set tgt [filefindbypath $fname]
495    if {[string length $tgt]} {
496        uplevel "source $tgt"
497    } else {
498        return -code error "Unable to find include file $fname"
499    }
500}
501
502# makeuserproc
503# This procedure re-writes the user-defined custom target to include
504# all the globals in its scope.  This is undeniably ugly, but I haven't
505# thought of any other way to do this.
506proc makeuserproc {name body} {
507    regsub -- "^\{(.*?)" $body "\{ \n foreach g \[info globals\] \{ \n global \$g \n \} \n \\1" body
508    eval "proc $name {} $body"
509}
510
511########### Internal Dependancy Manipulation Procedures ###########
512
513proc target_run {ditem} {
514    global target_state_fd portname
515    set result 0
516    set procedure [ditem_key $ditem procedure]
517    if {$procedure != ""} {
518        set name [ditem_key $ditem name]
519       
520        if {[ditem_contains $ditem init]} {
521            set result [catch {[ditem_key $ditem init] $name} errstr]
522        }
523       
524        if {[check_statefile target $name $target_state_fd] && $result == 0} {
525            set result 0
526            ui_debug "Skipping completed $name ($portname)"
527        } elseif {$result == 0} {
528            # Execute pre-run procedure
529            if {[ditem_contains $ditem prerun]} {
530                set result [catch {[ditem_key $ditem prerun] $name} errstr]
531            }
532           
533            if {$result == 0} {
534                foreach pre [ditem_key $ditem pre] {
535                    ui_debug "Executing $pre"
536                    set result [catch {$pre $name} errstr]
537                    if {$result != 0} { break }
538                }
539            }
540           
541            if {$result == 0} {
542                ui_debug "Executing $name ($portname)"
543                set result [catch {$procedure $name} errstr]
544            }
545           
546            if {$result == 0} {
547                foreach post [ditem_key $ditem post] {
548                    ui_debug "Executing $post"
549                    set result [catch {$post $name} errstr]
550                    if {$result != 0} { break }
551                }
552            }
553            # Execute post-run procedure
554            if {[ditem_contains $ditem postrun] && $result == 0} {
555                set postrun [ditem_key $ditem postrun]
556                ui_debug "Executing $postrun"
557                set result [catch {$postrun $name} errstr]
558            }
559        }
560        if {$result == 0} {
561            if {[ditem_key $ditem runtype] != "always"} {
562                write_statefile target $name $target_state_fd
563            }
564        } else {
565            ui_error "Target $name returned: $errstr"
566            set result 1
567        }
568       
569    } else {
570        ui_info "Warning: $name does not have a registered procedure"
571        set result 1
572    }
573   
574    return $result
575}
576
577proc eval_targets {target} {
578    global targets target_state_fd portname
579    set dlist $targets
580           
581        # Select the subset of targets under $target
582    if {$target != ""} {
583        set matches [dlist_search $dlist provides $target]
584
585        if {[llength $matches] > 0} {
586                        set dlist [dlist_append_dependents $dlist [lindex $matches 0] [list]]
587                        # Special-case 'all'
588                } elseif {$target != "all"} {
589                        ui_error "unknown target: $target"
590            return 1
591        }
592    }
593       
594    # Restore the state from a previous run.
595    set target_state_fd [open_statefile]
596   
597    set dlist [dlist_eval $dlist "" target_run]
598
599    if {[llength $dlist] > 0} {
600                # somebody broke!
601                set errstring "Warning: the following items did not execute (for $portname):"
602                foreach ditem $dlist {
603                        append errstring " [ditem_key $ditem name]"
604                }
605                ui_info $errstring
606                set result 1
607    } else {
608                set result 0
609    }
610       
611    close $target_state_fd
612    return $result
613}
614
615# open_statefile
616# open file to store name of completed targets
617proc open_statefile {args} {
618    global workpath portname portpath ports_ignore_older
619   
620    if {![file isdirectory $workpath]} {
621        file mkdir $workpath
622    }
623    # flock Portfile
624    set statefile [file join $workpath .darwinports.${portname}.state]
625    if {[file exists $statefile]} {
626                if {![file writable $statefile]} {
627                        return -code error "$statefile is not writable - check permission on port directory"
628                }
629                if {!([info exists ports_ignore_older] && $ports_ignore_older == "yes") && [file mtime $statefile] < [file mtime ${portpath}/Portfile]} {
630                        ui_msg "Portfile changed since last build; discarding previous state."
631                        #file delete $statefile
632                        exec rm -rf [file join $workpath]
633                        exec mkdir [file join $workpath]
634                }
635        }
636       
637    set fd [open $statefile a+]
638    if {[catch {flock $fd -exclusive -noblock} result]} {
639        if {"$result" == "EAGAIN"} {
640            ui_msg "Waiting for lock on $statefile"
641        } elseif {"$result" == "EOPNOTSUPP"} {
642            # Locking not supported, just return
643            return $fd
644        } else {
645            return -code error "$result obtaining lock on $statefile"
646        }
647    }
648    flock $fd -exclusive
649    return $fd
650}
651
652# check_statefile
653# Check completed/selected state of target/variant $name
654proc check_statefile {class name fd} {
655    global portpath workdir
656       
657    seek $fd 0
658    while {[gets $fd line] >= 0} {
659                if {$line == "$class: $name"} {
660                        return 1
661                }
662    }
663    return 0
664}
665
666# write_statefile
667# Set target $name completed in the state file
668proc write_statefile {class name fd} {
669    if {[check_statefile $class $name $fd]} {
670                return 0
671    }
672    seek $fd 0 end
673    puts $fd "$class: $name"
674    flush $fd
675}
676
677# check_statefile_variants
678# Check that recorded selection of variants match the current selection
679proc check_statefile_variants {variations fd} {
680        upvar $variations upvariations
681       
682    seek $fd 0
683    while {[gets $fd line] >= 0} {
684                if {[regexp "variant: (.*)" $line match name]} {
685                        set oldvariations([string range $name 1 end]) [string range $name 0 0]
686                }
687    }
688
689        set mismatch 0
690        if {[array size oldvariations] > 0} {
691                if {[array size oldvariations] != [array size upvariations]} {
692                        set mismatch 1
693                } else {
694                        foreach key [array names upvariations *] {
695                                if {$upvariations($key) != $oldvariations($key)} {
696                                        set mismatch 1
697                                        break
698                                }
699                        }
700                }
701        }
702
703        return $mismatch
704}
705
706# Traverse the ports collection hierarchy and call procedure func for
707# each directory containing a Portfile
708proc port_traverse {func {dir .}} {
709    set pwd [pwd]
710    if {[catch {cd $dir} err]} {
711        ui_error $err
712        return
713    }
714    foreach name [readdir .] {
715        if {[string match $name .] || [string match $name ..]} {
716            continue
717        }
718        if {[file isdirectory $name]} {
719            port_traverse $func $name
720        } else {
721            if {[string match $name Portfile]} {
722                catch {eval $func {[file join $pwd $dir]}}
723            }
724        }
725    }
726    cd $pwd
727}
728
729
730########### Port Variants ###########
731
732# Each variant which provides a subset of the requested variations
733# will be chosen.  Returns a list of the selected variants.
734proc choose_variants {dlist variations} {
735    upvar $variations upvariations
736   
737    set selected [list]
738   
739    foreach ditem $dlist {
740        # Enumerate through the provides, tallying the pros and cons.
741        set pros 0
742        set cons 0
743        set ignored 0
744        foreach flavor [ditem_key $ditem provides] {
745            if {[info exists upvariations($flavor)]} {
746                if {$upvariations($flavor) == "+"} {
747                    incr pros
748                } elseif {$upvariations($flavor) == "-"} {
749                    incr cons
750                }
751            } else {
752                incr ignored
753            }
754        }
755       
756        if {$cons > 0} { continue }
757       
758        if {$pros > 0 && $ignored == 0} {
759            lappend selected $ditem
760        }
761    }
762    return $selected
763}
764
765proc variant_run {ditem} {
766    set name [ditem_key $ditem name]
767    ui_debug "Executing $name provides [ditem_key $ditem provides]"
768
769        # test for conflicting variants
770        foreach v [ditem_key $ditem conflicts] {
771                if {[variant_isset $v]} {
772                        ui_error "Variant $name conflicts with $v"
773                        return 1
774                }
775        }
776
777    # execute proc with same name as variant.
778    if {[catch "variant-${name}" result]} {
779        ui_error "Error executing $name: $result"
780        return 1
781    }
782    return 0
783}
784
785proc eval_variants {variations target} {
786    global all_variants ports_force
787    set dlist $all_variants
788        set result 0
789    upvar $variations upvariations
790    set chosen [choose_variants $dlist upvariations]
791   
792    # now that we've selected variants, change all provides [a b c] to [a-b-c]
793    # this will eliminate ambiguity between item a, b, and a-b while fulfilling requirments.
794    #foreach obj $dlist {
795    #    $obj set provides [list [join [$obj get provides] -]]
796    #}
797   
798    set newlist [list]
799    foreach variant $chosen {
800        set newlist [dlist_append_dependents $dlist $variant $newlist]
801    }
802   
803    dlist_eval $newlist "" variant_run
804       
805        # Make sure the variations match those stored in the statefile.
806        # If they don't match, print an error indicating a 'port clean'
807        # should be performed. 
808        # - Skip this test if the statefile is empty.
809        # - Skip this test if performing a clean.
810        # - Skip this test if ports_force was specified.
811
812        if {$target != "clean" && 
813                !([info exists ports_force] && $ports_force == "yes")} {
814                set state_fd [open_statefile]
815       
816                if {[check_statefile_variants upvariations $state_fd]} {
817                        ui_error "Requested variants do not match original selection.\nPlease perform 'port clean' or specify the force option."
818                        set result 1
819                } else {
820                        # Write variations out to the statefile
821                        foreach key [array names upvariations *] {
822                                write_statefile variant $upvariations($key)$key $state_fd
823                        }
824                }
825               
826                close $state_fd
827        }
828       
829        return $result
830}
831
832# Target class definition.
833
834# constructor for target object
835proc target_new {name procedure} {
836    global targets
837    set ditem [ditem_create]
838       
839        ditem_key $ditem name $name
840        ditem_key $ditem procedure $procedure
841   
842    lappend targets $ditem
843   
844    return $ditem
845}
846
847proc target_provides {ditem args} {
848    global targets
849    # Register the pre-/post- hooks for use in Portfile.
850    # Portfile syntax: pre-fetch { puts "hello world" }
851    # User-code exceptions are caught and returned as a result of the target.
852    # Thus if the user code breaks, dependent targets will not execute.
853    foreach target $args {
854        set origproc [ditem_key $ditem procedure]
855        set ident [ditem_key $ditem name]
856        if {[info commands $target] != ""} {
857            ui_debug "$ident registered provides \'$target\', a pre-existing procedure. Target override will not be provided"
858        } else {
859                eval "proc $target {args} \{ \n\
860                        ditem_key $ditem procedure proc-${ident}-${target}
861                        eval \"proc proc-${ident}-${target} \{name\} \{ \n\
862                                if \{\\\[catch userproc-${ident}-${target} result\\\]\} \{ \n\
863                                        return -code error \\\$result \n\
864                                \} else \{ \n\
865                                        return 0 \n\
866                                \} \n\
867                        \}\" \n\
868                        eval \"proc do-$target \{\} \{ $origproc $target\}\" \n\
869                        makeuserproc userproc-${ident}-${target} \$args \n\
870                \}"
871        }
872        eval "proc pre-$target {args} \{ \n\
873                        ditem_append $ditem pre proc-pre-${ident}-${target}
874                        eval \"proc proc-pre-${ident}-${target} \{name\} \{ \n\
875                                if \{\\\[catch userproc-pre-${ident}-${target} result\\\]\} \{ \n\
876                                        return -code error \\\$result \n\
877                                \} else \{ \n\
878                                        return 0 \n\
879                                \} \n\
880                        \}\" \n\
881                        makeuserproc userproc-pre-${ident}-${target} \$args \n\
882                \}"
883        eval "proc post-$target {args} \{ \n\
884                        ditem_append $ditem post proc-post-${ident}-${target}
885                        eval \"proc proc-post-${ident}-${target} \{name\} \{ \n\
886                                if \{\\\[catch userproc-post-${ident}-${target} result\\\]\} \{ \n\
887                                        return -code error \\\$result \n\
888                                \} else \{ \n\
889                                        return 0 \n\
890                                \} \n\
891                        \}\" \n\
892                        makeuserproc userproc-post-${ident}-${target} \$args \n\
893                \}"
894    }
895    eval "ditem_append $ditem provides $args"
896}
897
898proc target_requires {ditem args} {
899    eval "ditem_append $ditem requires $args"
900}
901
902proc target_uses {ditem args} {
903    eval "ditem_append $ditem uses $args"
904}
905
906proc target_deplist {ditem args} {
907    eval "ditem_append $ditem deplist $args"
908}
909
910proc target_prerun {ditem args} {
911    eval "ditem_append $ditem prerun $args"
912}
913
914proc target_postrun {ditem args} {
915    eval "ditem_append $ditem postrun $args"
916}
917
918proc target_runtype {ditem args} {
919        eval "ditem_append $ditem runtype $args"
920}
921
922proc target_init {ditem args} {
923    eval "ditem_append $ditem init $args"
924}
925
926##### variant class #####
927
928# constructor for variant objects
929proc variant_new {name} {
930    set ditem [ditem_create]
931    ditem_key $ditem name $name
932    return $ditem
933}
934
935proc handle_default_variants {option action args} {
936    global variations
937    switch -regex $action {
938        set|append {
939            foreach v $args {
940                if {[regexp {([-+])([-A-Za-z0-9_]+)} $v whole val variant]} {
941                    if {![info exists variations($variant)]} {
942                        set variations($variant) $val
943                    }
944                }
945            }
946        }
947        delete {
948            # xxx
949        }
950    }
951}
952
953
954# builds the specified port (looked up in the index) to the specified target
955# doesn't yet support options or variants...
956# newworkpath defines the port's workpath - useful for when one port relies
957# on the source, etc, of another
958proc portexec_int {portname target {newworkpath ""}} {
959    ui_debug "Executing $target ($portname)"
960    set variations [list]
961    if {$newworkpath == ""} {
962        array set options [list]
963    } else {
964        set options(workpath) ${newworkpath}
965    }
966        # Escape regex special characters
967        regsub -all "(\\(){1}|(\\)){1}|(\\{1}){1}|(\\+){1}|(\\{1}){1}|(\\{){1}|(\\}){1}|(\\^){1}|(\\$){1}|(\\.){1}|(\\\\){1}" $portname "\\\\&" search_string
968
969    set res [dportsearch ^$search_string\$]
970    if {[llength $res] < 2} {
971        ui_error "Dependency $portname not found"
972        return -1
973    }
974
975    array set portinfo [lindex $res 1]
976    set porturl $portinfo(porturl)
977    if {[catch {set worker [dportopen $porturl [array get options] $variations]} result]} {
978        ui_error "Opening $portname $target failed: $result"
979        return -1
980    }
981    if {[catch {dportexec $worker $target} result] || $result != 0} {
982        ui_error "Execution $portname $target failed: $result"
983        dportclose $worker
984        return -1
985    }
986    dportclose $worker
987   
988    return 0
989}
990
991# portfile primitive that calls portexec_int with newworkpath == ${workpath}
992proc portexec {portname target} {
993    global workpath
994    return [portexec_int $portname $target $workpath]
995}
996
997proc adduser {name args} {
998    global os.platform
999    set passwd {\*}
1000    set uid [nextuid]
1001    set gid [existsgroup nogroup]
1002    set realname ${name}
1003    set home /dev/null
1004    set shell /dev/null
1005
1006    foreach arg $args {
1007        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
1008            regsub -all " " ${val} "\\ " val
1009            set $key $val
1010        }
1011    }
1012
1013    if {[existsuser ${name}] != 0 || [existsuser ${uid}] != 0} {
1014        return
1015    }
1016
1017    if {${os.platform} == "darwin"} {
1018        system "niutil -create . /users/${name}"
1019        system "niutil -createprop . /users/${name} name ${name}"
1020        system "niutil -createprop . /users/${name} passwd ${passwd}"
1021        system "niutil -createprop . /users/${name} uid ${uid}"
1022        system "niutil -createprop . /users/${name} gid ${gid}"
1023        system "niutil -createprop . /users/${name} realname ${realname}"
1024        system "niutil -createprop . /users/${name} home ${home}"
1025        system "niutil -createprop . /users/${name} shell ${shell}"
1026    } else {
1027        # XXX adduser is only available for darwin, add more support here
1028        ui_warn "WARNING: adduser is not implemented on ${os.platform}."
1029        ui_warn "The requested user was not created."
1030    }
1031}
1032
1033proc addgroup {name args} {
1034    global os.platform
1035    set gid [nextgid]
1036    set passwd {\*}
1037    set users ""
1038
1039    foreach arg $args {
1040        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
1041            regsub -all " " ${val} "\\ " val
1042            set $key $val
1043        }
1044    }
1045
1046    if {[existsgroup ${name}] != 0 || [existsgroup ${gid}] != 0} {
1047        return
1048    }
1049
1050    if {${os.platform} == "darwin"} {
1051        system "niutil -create . /groups/${name}"
1052        system "niutil -createprop . /groups/${name} name ${name}"
1053        system "niutil -createprop . /groups/${name} gid ${gid}"
1054        system "niutil -createprop . /groups/${name} passwd ${passwd}"
1055        system "niutil -createprop . /groups/${name} users ${users}"
1056    } else {
1057        # XXX addgroup is only available for darwin, add more support here
1058        ui_warn "WARNING: addgroup is not implemented on ${os.platform}."
1059        ui_warn "The requested group was not created."
1060    }
1061}
1062
1063# proc to calculate size of a directory
1064# moved here from portpackage.tcl
1065proc dirSize {dir} {
1066    set size    0;
1067    foreach file [readdir $dir] {
1068        if {$file == "." || $file == ".." || [file type [file join $dir $file]] == "link" } {
1069            continue
1070        }
1071        if {[file isdirectory [file join $dir $file]]} {
1072            incr size [dirSize [file join $dir $file]]
1073        } else {
1074            incr size [file size [file join $dir $file]];
1075        }
1076    }
1077    return $size;
1078}
1079
1080# check for a binary in the path
1081# returns an error code if it can not be found
1082proc binaryInPath {binary} {
1083    global env
1084    foreach dir [split $env(PATH) :] { 
1085        if {[file executable [file join $dir $binary]]} {
1086            return [file join $dir $binary]
1087        }
1088    }
1089   
1090    return -code error [format [msgcat::mc "Failed to locate '%s' in path: '%s'"] $binary $env(PATH)];
1091}
Note: See TracBrowser for help on using the repository browser.