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

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

Fix all conditionals that are missing braces
Submitted by: Jason Corley <jcorley1@…>

  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 27.6 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 {exec cp $tmpfile $file} error]} {
397            ui_error "reinplace: $error"
398            file delete "$tmpfile"
399            return -code error "reinplace failed"
400        }
401        file delete "$tmpfile"
402    }
403    return
404}
405
406# filefindbypath
407# Provides searching of the standard path for included files
408proc filefindbypath {fname} {
409    global distpath filedir workdir worksrcdir portpath
410
411    if {[file readable $portpath/$fname]} {
412        return $portpath/$fname
413    } elseif {[file readable $portpath/$filedir/$fname]} {
414        return $portpath/$filedir/$fname
415    } elseif {[file readable $distpath/$fname]} {
416        return $distpath/$fname
417    }
418    return ""
419}
420
421# include
422# Source a file, looking for it along a standard search path.
423proc include {fname} {
424    set tgt [filefindbypath $fname]
425    if {[string length $tgt]} {
426        uplevel "source $tgt"
427    } else {
428        return -code error "Unable to find include file $fname"
429    }
430}
431
432# makeuserproc
433# This procedure re-writes the user-defined custom target to include
434# all the globals in its scope.  This is undeniably ugly, but I haven't
435# thought of any other way to do this.
436proc makeuserproc {name body} {
437    regsub -- "^\{(.*?)" $body "\{ \n foreach g \[info globals\] \{ \n global \$g \n \} \n \\1" body
438    eval "proc $name {} $body"
439}
440
441########### Internal Dependancy Manipulation Procedures ###########
442
443proc target_run {ditem} {
444    global target_state_fd portname
445    set result 0
446    set procedure [ditem_key $ditem procedure]
447    if {$procedure != ""} {
448        set name [ditem_key $ditem name]
449       
450        if {[ditem_contains $ditem init]} {
451            set result [catch {[ditem_key $ditem init] $name} errstr]
452        }
453       
454        if {[check_statefile target $name $target_state_fd] && $result == 0} {
455            set result 0
456            ui_debug "Skipping completed $name ($portname)"
457        } elseif {$result == 0} {
458            # Execute pre-run procedure
459            if {[ditem_contains $ditem prerun]} {
460                set result [catch {[ditem_key $ditem prerun] $name} errstr]
461            }
462           
463            if {$result == 0} {
464                foreach pre [ditem_key $ditem pre] {
465                    ui_debug "Executing $pre"
466                    set result [catch {$pre $name} errstr]
467                    if {$result != 0} { break }
468                }
469            }
470           
471            if {$result == 0} {
472                ui_debug "Executing $name ($portname)"
473                set result [catch {$procedure $name} errstr]
474            }
475           
476            if {$result == 0} {
477                foreach post [ditem_key $ditem post] {
478                    ui_debug "Executing $post"
479                    set result [catch {$post $name} errstr]
480                    if {$result != 0} { break }
481                }
482            }
483            # Execute post-run procedure
484            if {[ditem_contains $ditem postrun] && $result == 0} {
485                set postrun [ditem_key $ditem postrun]
486                ui_debug "Executing $postrun"
487                set result [catch {$postrun $name} errstr]
488            }
489        }
490        if {$result == 0} {
491            if {[ditem_key $ditem runtype] != "always"} {
492                write_statefile target $name $target_state_fd
493            }
494        } else {
495            ui_error "Target $name returned: $errstr"
496            set result 1
497        }
498       
499    } else {
500        ui_info "Warning: $name does not have a registered procedure"
501        set result 1
502    }
503   
504    return $result
505}
506
507proc eval_targets {target} {
508    global targets target_state_fd portname
509    set dlist $targets
510           
511        # Select the subset of targets under $target
512    if {$target != ""} {
513        set matches [dlist_search $dlist provides $target]
514
515        if {[llength $matches] > 0} {
516                        set dlist [dlist_append_dependents $dlist [lindex $matches 0] [list]]
517                        # Special-case 'all'
518                } elseif {$target != "all"} {
519                        ui_info "unknown target: $target"
520            return 1
521        }
522    }
523       
524    # Restore the state from a previous run.
525    set target_state_fd [open_statefile]
526   
527    set dlist [dlist_eval $dlist "" target_run]
528
529    if {[llength $dlist] > 0} {
530                # somebody broke!
531                set errstring "Warning: the following items did not execute (for $portname):"
532                foreach ditem $dlist {
533                        append errstring " [ditem_key $ditem name]"
534                }
535                ui_info $errstring
536                set result 1
537    } else {
538                set result 0
539    }
540       
541    close $target_state_fd
542    return $result
543}
544
545# open_statefile
546# open file to store name of completed targets
547proc open_statefile {args} {
548    global workpath portname portpath ports_ignore_older
549   
550    if {![file isdirectory $workpath]} {
551        file mkdir $workpath
552    }
553    # flock Portfile
554    set statefile [file join $workpath .darwinports.${portname}.state]
555    if {[file exists $statefile]} {
556                if {![file writable $statefile]} {
557                        return -code error "$statefile is not writable - check permission on port directory"
558                }
559                if {!([info exists ports_ignore_older] && $ports_ignore_older == "yes") && [file mtime $statefile] < [file mtime ${portpath}/Portfile]} {
560                        ui_msg "Portfile changed since last build; discarding previous state."
561                        #file delete $statefile
562                        exec rm -rf [file join $workpath]
563                        exec mkdir [file join $workpath]
564                }
565        }
566       
567    set fd [open $statefile a+]
568    if {[catch {flock $fd -exclusive -noblock} result]} {
569        if {"$result" == "EAGAIN"} {
570            ui_msg "Waiting for lock on $statefile"
571        } elseif {"$result" == "EOPNOTSUPP"} {
572            # Locking not supported, just return
573            return $fd
574        } else {
575            return -code error "$result obtaining lock on $statefile"
576        }
577    }
578    flock $fd -exclusive
579    return $fd
580}
581
582# check_statefile
583# Check completed/selected state of target/variant $name
584proc check_statefile {class name fd} {
585    global portpath workdir
586       
587    seek $fd 0
588    while {[gets $fd line] >= 0} {
589                if {$line == "$class: $name"} {
590                        return 1
591                }
592    }
593    return 0
594}
595
596# write_statefile
597# Set target $name completed in the state file
598proc write_statefile {class name fd} {
599    if {[check_statefile $class $name $fd]} {
600                return 0
601    }
602    seek $fd 0 end
603    puts $fd "$class: $name"
604    flush $fd
605}
606
607# check_statefile_variants
608# Check that recorded selection of variants match the current selection
609proc check_statefile_variants {variations fd} {
610        upvar $variations upvariations
611       
612    seek $fd 0
613    while {[gets $fd line] >= 0} {
614                if {[regexp "variant: (.*)" $line match name]} {
615                        set oldvariations([string range $name 1 end]) [string range $name 0 0]
616                }
617    }
618
619        set mismatch 0
620        if {[array size oldvariations] > 0} {
621                if {[array size oldvariations] != [array size upvariations]} {
622                        set mismatch 1
623                } else {
624                        foreach key [array names upvariations *] {
625                                if {$upvariations($key) != $oldvariations($key)} {
626                                        set mismatch 1
627                                        break
628                                }
629                        }
630                }
631        }
632
633        return $mismatch
634}
635
636# Traverse the ports collection hierarchy and call procedure func for
637# each directory containing a Portfile
638proc port_traverse {func {dir .}} {
639    set pwd [pwd]
640    if {[catch {cd $dir} err]} {
641        ui_error $err
642        return
643    }
644    foreach name [readdir .] {
645        if {[string match $name .] || [string match $name ..]} {
646            continue
647        }
648        if {[file isdirectory $name]} {
649            port_traverse $func $name
650        } else {
651            if {[string match $name Portfile]} {
652                catch {eval $func {[file join $pwd $dir]}}
653            }
654        }
655    }
656    cd $pwd
657}
658
659
660########### Port Variants ###########
661
662# Each variant which provides a subset of the requested variations
663# will be chosen.  Returns a list of the selected variants.
664proc choose_variants {dlist variations} {
665    upvar $variations upvariations
666   
667    set selected [list]
668   
669    foreach ditem $dlist {
670        # Enumerate through the provides, tallying the pros and cons.
671        set pros 0
672        set cons 0
673        set ignored 0
674        foreach flavor [ditem_key $ditem provides] {
675            if {[info exists upvariations($flavor)]} {
676                if {$upvariations($flavor) == "+"} {
677                    incr pros
678                } elseif {$upvariations($flavor) == "-"} {
679                    incr cons
680                }
681            } else {
682                incr ignored
683            }
684        }
685       
686        if {$cons > 0} { continue }
687       
688        if {$pros > 0 && $ignored == 0} {
689            lappend selected $ditem
690        }
691    }
692    return $selected
693}
694
695proc variant_run {ditem} {
696    set name [ditem_key $ditem name]
697    ui_debug "Executing $name provides [ditem_key $ditem provides]"
698
699        # test for conflicting variants
700        foreach v [ditem_key $ditem conflicts] {
701                if {[variant_isset $v]} {
702                        ui_error "Variant $name conflicts with $v"
703                        return 1
704                }
705        }
706
707    # execute proc with same name as variant.
708    if {[catch "variant-${name}" result]} {
709        ui_error "Error executing $name: $result"
710        return 1
711    }
712    return 0
713}
714
715proc eval_variants {variations target} {
716    global all_variants ports_force
717    set dlist $all_variants
718        set result 0
719    upvar $variations upvariations
720    set chosen [choose_variants $dlist upvariations]
721   
722    # now that we've selected variants, change all provides [a b c] to [a-b-c]
723    # this will eliminate ambiguity between item a, b, and a-b while fulfilling requirments.
724    #foreach obj $dlist {
725    #    $obj set provides [list [join [$obj get provides] -]]
726    #}
727   
728    set newlist [list]
729    foreach variant $chosen {
730        set newlist [dlist_append_dependents $dlist $variant $newlist]
731    }
732   
733    dlist_eval $newlist "" variant_run
734       
735        # Make sure the variations match those stored in the statefile.
736        # If they don't match, print an error indicating a 'port clean'
737        # should be performed. 
738        # - Skip this test if the statefile is empty.
739        # - Skip this test if performing a clean.
740        # - Skip this test if ports_force was specified.
741
742        if {$target != "clean" && 
743                !([info exists ports_force] && $ports_force == "yes")} {
744                set state_fd [open_statefile]
745       
746                if {[check_statefile_variants upvariations $state_fd]} {
747                        ui_error "Requested variants do not match original selection.\nPlease perform 'port clean' or specify the force option."
748                        set result 1
749                } else {
750                        # Write variations out to the statefile
751                        foreach key [array names upvariations *] {
752                                write_statefile variant $upvariations($key)$key $state_fd
753                        }
754                }
755               
756                close $state_fd
757        }
758       
759        return $result
760}
761
762# Target class definition.
763
764# constructor for target object
765proc target_new {name procedure} {
766    global targets
767    set ditem [ditem_create]
768       
769        ditem_key $ditem name $name
770        ditem_key $ditem procedure $procedure
771   
772    lappend targets $ditem
773   
774    return $ditem
775}
776
777proc target_provides {ditem args} {
778    global targets
779    # Register the pre-/post- hooks for use in Portfile.
780    # Portfile syntax: pre-fetch { puts "hello world" }
781    # User-code exceptions are caught and returned as a result of the target.
782    # Thus if the user code breaks, dependent targets will not execute.
783    foreach target $args {
784        set origproc [ditem_key $ditem procedure]
785        set ident [ditem_key $ditem name]
786        if {[info commands $target] != ""} {
787            ui_debug "$ident registered provides \'$target\', a pre-existing procedure. Target override will not be provided"
788        } else {
789                eval "proc $target {args} \{ \n\
790                        ditem_key $ditem procedure proc-${ident}-${target}
791                        eval \"proc proc-${ident}-${target} \{name\} \{ \n\
792                                if \{\\\[catch userproc-${ident}-${target} result\\\]\} \{ \n\
793                                        return -code error \\\$result \n\
794                                \} else \{ \n\
795                                        return 0 \n\
796                                \} \n\
797                        \}\" \n\
798                        eval \"proc do-$target \{\} \{ $origproc $target\}\" \n\
799                        makeuserproc userproc-${ident}-${target} \$args \n\
800                \}"
801        }
802        eval "proc pre-$target {args} \{ \n\
803                        ditem_append $ditem pre proc-pre-${ident}-${target}
804                        eval \"proc proc-pre-${ident}-${target} \{name\} \{ \n\
805                                if \{\\\[catch userproc-pre-${ident}-${target} result\\\]\} \{ \n\
806                                        return -code error \\\$result \n\
807                                \} else \{ \n\
808                                        return 0 \n\
809                                \} \n\
810                        \}\" \n\
811                        makeuserproc userproc-pre-${ident}-${target} \$args \n\
812                \}"
813        eval "proc post-$target {args} \{ \n\
814                        ditem_append $ditem post proc-post-${ident}-${target}
815                        eval \"proc proc-post-${ident}-${target} \{name\} \{ \n\
816                                if \{\\\[catch userproc-post-${ident}-${target} result\\\]\} \{ \n\
817                                        return -code error \\\$result \n\
818                                \} else \{ \n\
819                                        return 0 \n\
820                                \} \n\
821                        \}\" \n\
822                        makeuserproc userproc-post-${ident}-${target} \$args \n\
823                \}"
824    }
825    eval "ditem_append $ditem provides $args"
826}
827
828proc target_requires {ditem args} {
829    eval "ditem_append $ditem requires $args"
830}
831
832proc target_uses {ditem args} {
833    eval "ditem_append $ditem uses $args"
834}
835
836proc target_deplist {ditem args} {
837    eval "ditem_append $ditem deplist $args"
838}
839
840proc target_prerun {ditem args} {
841    eval "ditem_append $ditem prerun $args"
842}
843
844proc target_postrun {ditem args} {
845    eval "ditem_append $ditem postrun $args"
846}
847
848proc target_runtype {ditem args} {
849        eval "ditem_append $ditem runtype $args"
850}
851
852proc target_init {ditem args} {
853    eval "ditem_append $ditem init $args"
854}
855
856##### variant class #####
857
858# constructor for variant objects
859proc variant_new {name} {
860    set ditem [ditem_create]
861    ditem_key $ditem name $name
862    return $ditem
863}
864
865proc handle_default_variants {option action args} {
866    global variations
867    switch -regex $action {
868        set|append {
869            foreach v $args {
870                if {[regexp {([-+])([-A-Za-z0-9_]+)} $v whole val variant]} {
871                    if {![info exists variations($variant)]} {
872                        set variations($variant) $val
873                    }
874                }
875            }
876        }
877        delete {
878            # xxx
879        }
880    }
881}
882
883
884# builds the specified port (looked up in the index) to the specified target
885# doesn't yet support options or variants...
886# newworkpath defines the port's workpath - useful for when one port relies
887# on the source, etc, of another
888proc portexec_int {portname target {newworkpath ""}} {
889    ui_debug "Executing $target ($portname)"
890    set variations [list]
891    if {$newworkpath == ""} {
892        array set options [list]
893    } else {
894        set options(workpath) ${newworkpath}
895    }
896        # Escape regex special characters
897        regsub -all "(\\(){1}|(\\)){1}|(\\{1}){1}|(\\+){1}|(\\{1}){1}|(\\{){1}|(\\}){1}|(\\^){1}|(\\$){1}|(\\.){1}|(\\\\){1}" $portname "\\\\&" search_string
898
899    set res [dportsearch ^$search_string\$]
900    if {[llength $res] < 2} {
901        ui_error "Dependency $portname not found"
902        return -1
903    }
904
905    array set portinfo [lindex $res 1]
906    set porturl $portinfo(porturl)
907    if {[catch {set worker [dportopen $porturl [array get options] $variations]} result]} {
908        ui_error "Opening $portname $target failed: $result"
909        return -1
910    }
911    if {[catch {dportexec $worker $target} result] || $result != 0} {
912        ui_error "Execution $portname $target failed: $result"
913        dportclose $worker
914        return -1
915    }
916    dportclose $worker
917   
918    return 0
919}
920
921# portfile primitive that calls portexec_int with newworkpath == ${workpath}
922proc portexec {portname target} {
923    global workpath
924    return [portexec_int $portname $target $workpath]
925}
926
927proc adduser {name args} {
928    global os.platform
929    set passwd {\*}
930    set uid [nextuid]
931    set gid [existsgroup nogroup]
932    set realname ${name}
933    set home /dev/null
934    set shell /dev/null
935
936    foreach arg $args {
937        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
938            regsub -all " " ${val} "\\ " val
939            set $key $val
940        }
941    }
942
943    if {[existsuser ${name}] != 0 || [existsuser ${uid}] != 0} {
944        return
945    }
946
947    if {${os.platform} == "darwin"} {
948        system "niutil -create . /users/${name}"
949        system "niutil -createprop . /users/${name} name ${name}"
950        system "niutil -createprop . /users/${name} passwd ${passwd}"
951        system "niutil -createprop . /users/${name} uid ${uid}"
952        system "niutil -createprop . /users/${name} gid ${gid}"
953        system "niutil -createprop . /users/${name} realname ${realname}"
954        system "niutil -createprop . /users/${name} home ${home}"
955        system "niutil -createprop . /users/${name} shell ${shell}"
956    } else {
957        # XXX adduser is only available for darwin, add more support here
958        ui_warn "WARNING: adduser is not implemented on ${os.platform}."
959        ui_warn "The requested user was not created."
960    }
961}
962
963proc addgroup {name args} {
964    global os.platform
965    set gid [nextgid]
966    set passwd {\*}
967    set users ""
968
969    foreach arg $args {
970        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
971            regsub -all " " ${val} "\\ " val
972            set $key $val
973        }
974    }
975
976    if {[existsgroup ${name}] != 0 || [existsgroup ${gid}] != 0} {
977        return
978    }
979
980    if {${os.platform} == "darwin"} {
981        system "niutil -create . /groups/${name}"
982        system "niutil -createprop . /groups/${name} name ${name}"
983        system "niutil -createprop . /groups/${name} gid ${gid}"
984        system "niutil -createprop . /groups/${name} passwd ${passwd}"
985        system "niutil -createprop . /groups/${name} users ${users}"
986    } else {
987        # XXX addgroup is only available for darwin, add more support here
988        ui_warn "WARNING: addgroup is not implemented on ${os.platform}."
989        ui_warn "The requested group was not created."
990    }
991}
Note: See TracBrowser for help on using the repository browser.