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

Last change on this file since 4454 was 4454, checked in by jkh, 15 years ago

Fix weirdness in options_proc where a local shadowed a global. This fixes
the ldelete call in the variant of the new port of ethereal.

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