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

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

For now, and it fixes ethereal without breaking anything else so I think
it's a good fix, trap unreferenced options in options_proc_trace and simply
return normally when encountering one. The depends_lib-delete statement
in ethereal *is* working, it's just causing this error as a side-effect so
detect it here. Longer term, I'll continue to look into why it's happening
at all and clobber it at the source. This band-aid simply prevents it from
blowing us up.

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