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

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

Use append instead of lappend

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