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

Last change on this file since 4456 was 4456, checked in by jkh, 14 years ago

Back out previous "fix" to option_proc - it only "worked" by masking the symptoms entirely. I'll have to
do more checking into why the option gets occasionally set to "uplist" and blows up the trace function.

P.S. This code is very hard to understand. I don't even know why it globalizes this variable, but it's
obviously essential to its function to do so. Just reading the function itself is not enlightening at
all given that this code is essentially write-only. Perhaps PERL should have been chosen as the implementation
language instead - at least then it would have been deliberate. :)

  • 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 $option
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.