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

Last change on this file since 2217 was 2217, checked in by kevin, 16 years ago

remove working directory when discarding previous state.

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