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

Last change on this file since 4155 was 4155, checked in by landonf, 15 years ago

When comparing old variants to new variants, check if the array key exists prior to checking its value.

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