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

Last change on this file since 2435 was 2435, checked in by landonf, 16 years ago

Update UI protocol to support versioning and message context, as well as future extended "meta-data"
Updated all command line clients to support new UI API

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