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

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

Try to use a somewhat unique name for the generated procedure

  • 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::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    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.