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

Last change on this file since 3410 was 3410, checked in by fkr, 15 years ago

Bug: #819
Submitted by: fenner@
Reviewed by:
Approved by:
Obtained from:

ui_error if target is not known.

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