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

Last change on this file since 2126 was 2126, checked in by kevin, 17 years ago

Added -o option to ignore modification times on state file and Portfile
  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 30.0 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                }
554        }
555       
556    set fd [open $statefile a+]
557    if [catch {flock $fd -exclusive -noblock} result] {
558        if {"$result" == "EAGAIN"} {
559            ui_msg "Waiting for lock on $statefile"
560        } elseif {"$result" == "EOPNOTSUPP"} {
561            # Locking not supported, just return
562            return $fd
563        } else {
564            return -code error "$result obtaining lock on $statefile"
565        }
566    }
567    flock $fd -exclusive
568    return $fd
569}
570
571# check_statefile
572# Check completed/selected state of target/variant $name
573proc check_statefile {class name fd} {
574    global portpath workdir
575       
576    seek $fd 0
577    while {[gets $fd line] >= 0} {
578                if {$line == "$class: $name"} {
579                        return 1
580                }
581    }
582    return 0
583}
584
585# write_statefile
586# Set target $name completed in the state file
587proc write_statefile {class name fd} {
588    if {[check_statefile $class $name $fd]} {
589                return 0
590    }
591    seek $fd 0 end
592    puts $fd "$class: $name"
593    flush $fd
594}
595
596# check_statefile_variants
597# Check that recorded selection of variants match the current selection
598proc check_statefile_variants {variations fd} {
599        upvar $variations upvariations
600       
601    seek $fd 0
602    while {[gets $fd line] >= 0} {
603                if {[regexp "variant: (.*)" $line match name]} {
604                        set oldvariations([string range $name 1 end]) [string range $name 0 0]
605                }
606    }
607
608        set mismatch 0
609        if {[array size oldvariations] > 0} {
610                if {[array size oldvariations] != [array size upvariations]} {
611                        set mismatch 1
612                } else {
613                        foreach key [array names upvariations *] {
614                                if {$upvariations($key) != $oldvariations($key)} {
615                                        set mismatch 1
616                                        break
617                                }
618                        }
619                }
620        }
621
622        return $mismatch
623}
624
625# Traverse the ports collection hierarchy and call procedure func for
626# each directory containing a Portfile
627proc port_traverse {func {dir .}} {
628    set pwd [pwd]
629    if [catch {cd $dir} err] {
630        ui_error $err
631        return
632    }
633    foreach name [readdir .] {
634        if {[string match $name .] || [string match $name ..]} {
635            continue
636        }
637        if [file isdirectory $name] {
638            port_traverse $func $name
639        } else {
640            if [string match $name Portfile] {
641                catch {eval $func {[file join $pwd $dir]}}
642            }
643        }
644    }
645    cd $pwd
646}
647
648
649########### Port Variants ###########
650
651# Each variant which provides a subset of the requested variations
652# will be chosen.  Returns a list of the selected variants.
653proc choose_variants {dlist variations} {
654    upvar $variations upvariations
655   
656    set selected [list]
657   
658    foreach ditem $dlist {
659        # Enumerate through the provides, tallying the pros and cons.
660        set pros 0
661        set cons 0
662        set ignored 0
663        foreach flavor [ditem_key $ditem provides] {
664            if {[info exists upvariations($flavor)]} {
665                if {$upvariations($flavor) == "+"} {
666                    incr pros
667                } elseif {$upvariations($flavor) == "-"} {
668                    incr cons
669                }
670            } else {
671                incr ignored
672            }
673        }
674       
675        if {$cons > 0} { continue }
676       
677        if {$pros > 0 && $ignored == 0} {
678            lappend selected $ditem
679        }
680    }
681    return $selected
682}
683
684proc variant_run {ditem} {
685    set name [ditem_key $ditem name]
686    ui_debug "Executing $name provides [ditem_key $ditem provides]"
687
688        # test for conflicting variants
689        foreach v [ditem_key $ditem conflicts] {
690                if {[variant_isset $v]} {
691                        ui_error "Variant $name conflicts with $v"
692                        return 1
693                }
694        }
695
696    # execute proc with same name as variant.
697    if {[catch "variant-${name}" result]} {
698        ui_error "Error executing $name: $result"
699        return 1
700    }
701    return 0
702}
703
704proc eval_variants {variations target} {
705    global all_variants ports_force
706    set dlist $all_variants
707        set result 0
708    upvar $variations upvariations
709    set chosen [choose_variants $dlist upvariations]
710   
711    # now that we've selected variants, change all provides [a b c] to [a-b-c]
712    # this will eliminate ambiguity between item a, b, and a-b while fulfilling requirments.
713    #foreach obj $dlist {
714    #    $obj set provides [list [join [$obj get provides] -]]
715    #}
716   
717    set newlist [list]
718    foreach variant $chosen {
719        set newlist [dlist_append_dependents $dlist $variant $newlist]
720    }
721   
722    dlist_eval $newlist "" variant_run
723       
724        # Make sure the variations match those stored in the statefile.
725        # If they don't match, print an error indicating a 'port clean'
726        # should be performed. 
727        # - Skip this test if the statefile is empty.
728        # - Skip this test if performing a clean.
729        # - Skip this test if ports_force was specified.
730
731        if {$target != "clean" && 
732                !([info exists ports_force] && $ports_force == "yes")} {
733                set state_fd [open_statefile]
734       
735                if {[check_statefile_variants upvariations $state_fd]} {
736                        ui_error "Requested variants do not match original selection.\nPlease perform 'port clean' or specify the force option."
737                        set result 1
738                } else {
739                        # Write variations out to the statefile
740                        foreach key [array names upvariations *] {
741                                write_statefile variant $upvariations($key)$key $state_fd
742                        }
743                }
744               
745                close $state_fd
746        }
747       
748        return $result
749}
750
751# Target class definition.
752
753# constructor for target object
754proc target_new {name procedure} {
755    global targets
756    set ditem [ditem_create]
757       
758        ditem_key $ditem name $name
759        ditem_key $ditem procedure $procedure
760   
761    lappend targets $ditem
762   
763    return $ditem
764}
765
766proc target_provides {ditem args} {
767    global targets
768    # Register the pre-/post- hooks for use in Portfile.
769    # Portfile syntax: pre-fetch { puts "hello world" }
770    # User-code exceptions are caught and returned as a result of the target.
771    # Thus if the user code breaks, dependent targets will not execute.
772    foreach target $args {
773        set origproc [ditem_key $ditem procedure]
774        set ident [ditem_key $ditem name]
775        if {[info commands $target] != ""} {
776            ui_debug "$ident registered provides \'$target\', a pre-existing procedure. Target override will not be provided"
777        } else {
778                eval "proc $target {args} \{ \n\
779                        ditem_key $ditem procedure proc-${ident}-${target}
780                        eval \"proc proc-${ident}-${target} \{name\} \{ \n\
781                                if \{\\\[catch userproc-${ident}-${target} result\\\]\} \{ \n\
782                                        return -code error \\\$result \n\
783                                \} else \{ \n\
784                                        return 0 \n\
785                                \} \n\
786                        \}\" \n\
787                        eval \"proc do-$target \{\} \{ $origproc $target\}\" \n\
788                        makeuserproc userproc-${ident}-${target} \$args \n\
789                \}"
790        }
791        eval "proc pre-$target {args} \{ \n\
792                        ditem_append $ditem pre proc-pre-${ident}-${target}
793                        eval \"proc proc-pre-${ident}-${target} \{name\} \{ \n\
794                                if \{\\\[catch userproc-pre-${ident}-${target} result\\\]\} \{ \n\
795                                        return -code error \\\$result \n\
796                                \} else \{ \n\
797                                        return 0 \n\
798                                \} \n\
799                        \}\" \n\
800                        makeuserproc userproc-pre-${ident}-${target} \$args \n\
801                \}"
802        eval "proc post-$target {args} \{ \n\
803                        ditem_append $ditem post proc-post-${ident}-${target}
804                        eval \"proc proc-post-${ident}-${target} \{name\} \{ \n\
805                                if \{\\\[catch userproc-post-${ident}-${target} result\\\]\} \{ \n\
806                                        return -code error \\\$result \n\
807                                \} else \{ \n\
808                                        return 0 \n\
809                                \} \n\
810                        \}\" \n\
811                        makeuserproc userproc-post-${ident}-${target} \$args \n\
812                \}"
813    }
814    eval "ditem_append $ditem provides $args"
815}
816
817proc target_requires {ditem args} {
818    eval "ditem_append $ditem requires $args"
819}
820
821proc target_uses {ditem args} {
822    eval "ditem_append $ditem uses $args"
823}
824
825proc target_deplist {ditem args} {
826    eval "ditem_append $ditem deplist $args"
827}
828
829proc target_prerun {ditem args} {
830    eval "ditem_append $ditem prerun $args"
831}
832
833proc target_postrun {ditem args} {
834    eval "ditem_append $ditem postrun $args"
835}
836
837proc target_runtype {ditem args} {
838        eval "ditem_append $ditem runtype $args"
839}
840
841proc target_init {ditem args} {
842    eval "ditem_append $ditem init $args"
843}
844
845##### variant class #####
846
847# constructor for variant objects
848proc variant_new {name} {
849    set ditem [ditem_create]
850    ditem_key $ditem name $name
851    return $ditem
852}
853
854proc handle_default_variants {option action args} {
855    global variations
856    switch -regex $action {
857        set|append {
858            foreach v $args {
859                if {[regexp {([-+])([-A-Za-z0-9_]+)} $v whole val variant]} {
860                    if {![info exists variations($variant)]} {
861                        set variations($variant) $val
862                    }
863                }
864            }
865        }
866        delete {
867            # xxx
868        }
869    }
870}
871
872
873# builds the specified port (looked up in the index) to the specified target
874# doesn't yet support options or variants...
875# newworkpath defines the port's workpath - useful for when one port relies
876# on the source, etc, of another
877proc portexec_int {portname target {newworkpath ""}} {
878    ui_debug "Executing $target ($portname)"
879    set variations [list]
880    if {$newworkpath == ""} {
881        array set options [list]
882    } else {
883        set options(workpath) ${newworkpath}
884    }
885        # Escape regex special characters
886        regsub -all "(\\(){1}|(\\)){1}|(\\{1}){1}|(\\+){1}|(\\{1}){1}|(\\{){1}|(\\}){1}|(\\^){1}|(\\$){1}|(\\.){1}|(\\\\){1}" $portname "\\\\&" search_string
887
888    set res [dportsearch ^$search_string\$]
889    if {[llength $res] < 2} {
890        ui_error "Dependency $portname not found"
891        return -1
892    }
893
894    array set portinfo [lindex $res 1]
895    set porturl $portinfo(porturl)
896    if {[catch {set worker [dportopen $porturl [array get options] $variations]} result]} {
897        ui_error "Opening $portname $target failed: $result"
898        return -1
899    }
900    if {[catch {dportexec $worker $target} result] || $result != 0} {
901        ui_error "Execution $portname $target failed: $result"
902        dportclose $worker
903        return -1
904    }
905    dportclose $worker
906   
907    return 0
908}
909
910proc portfile_search_path {depregex search_path} {
911    set found 0
912    foreach path $search_path {
913        if {![file isdirectory $path]} {
914            continue
915        }
916        foreach filename [readdir $path] {
917            if {[regexp $depregex $filename] == 1} {
918                ui_debug "Found Dependency: path: $path filename: $filename regex: $depregex"
919                set found 1
920                break
921            }
922        }
923    }
924    return $found
925}
926
927
928# XXX - Architecture specific
929# XXX - Rely on information from internal defines in cctools/dyld:
930# define DEFAULT_FALLBACK_FRAMEWORK_PATH
931# /Library/Frameworks:/Library/Frameworks:/Network/Library/Frameworks:/System/Library/Frameworks
932# define DEFAULT_FALLBACK_LIBRARY_PATH /lib:/usr/local/lib:/lib:/usr/lib
933# Environment variables DYLD_FRAMEWORK_PATH, DYLD_LIBRARY_PATH,
934# DYLD_FALLBACK_FRAMEWORK_PATH, and DYLD_FALLBACK_LIBRARY_PATH take precedence
935
936proc libportfile_test {this} {
937    global env prefix
938   
939    # Check the registry first
940    set result [portfile_test $this]
941    if {$result == 1} {
942        return $result
943    } else {
944        # Not in the registry, check the library path.
945        set depregex [$this get depregex]
946       
947        if {[info exists env(DYLD_FRAMEWORK_PATH)]} {
948            lappend search_path $env(DYLD_FRAMEWORK_PATH)
949        } else {
950            lappend search_path /Library/Frameworks /Network/Library/Frameworks /System/Library/Frameworks
951        }
952        if {[info exists env(DYLD_FALLBACK_FRAMEWORK_PATH)]} {
953            lappend search_path $env(DYLD_FALLBACK_FRAMEWORK_PATH)
954        }
955        if {[info exists env(DYLD_LIBRARY_PATH)]} {
956            lappend search_path $env(DYLD_LIBRARY_PATH)
957        } else {
958            lappend search_path /lib /usr/local/lib /lib /usr/lib /op/local/lib /usr/X11R6/lib ${prefix}/lib
959        }
960        if {[info exists env(DYLD_FALLBACK_LIBRARY_PATH)]} {
961            lappend search_path $env(DYLD_LIBRARY_PATH)
962        }
963        regsub {\.} $depregex {\.} depregex
964        set depregex \^$depregex.*\\.dylib\$
965       
966        return [portfile_search_path $depregex $search_path]
967    }
968}
969
970proc binportfile_test {this} {
971    global env prefix
972   
973    # Check the registry first
974    set result [portfile_test $this]
975    if {$result == 1} {
976        return $result
977    } else {
978        # Not in the registry, check the binary path.
979        set depregex [$this get depregex]
980       
981        set search_path [split $env(PATH) :]
982       
983        set depregex \^$depregex\$
984       
985        return [portfile_search_path $depregex $search_path]
986    }
987}
988
989proc pathportfile_test {this} {
990    global env prefix
991   
992    # Check the registry first
993    set result [portfile_test $this]
994    if {$result == 1} {
995        return $result
996    } else {
997        # Not in the registry, check the path.
998        # separate directory from regex
999        set fullname [$this get depregex]
1000
1001        regexp {^(.*)/(.*?)$} "$fullname" match search_path depregex
1002
1003        if {[string index $search_path 0] != "/"} {
1004                # Prepend prefix if not an absolute path
1005                set search_path "${prefix}/${search_path}"
1006        }
1007               
1008        set depregex \^$depregex\$
1009       
1010        return [portfile_search_path $depregex $search_path]
1011    }
1012}
1013
1014proc adduser {name args} {
1015    global os.platform
1016    set passwd {\*}
1017    set uid [nextuid]
1018    set gid [existsgroup nogroup]
1019    set realname ${name}
1020    set home /dev/null
1021    set shell /dev/null
1022
1023    foreach arg $args {
1024        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
1025            regsub -all " " ${val} "\\ " val
1026            set $key $val
1027        }
1028    }
1029
1030    if {[existsuser ${name}] != 0 || [existsuser ${uid}] != 0} {
1031        return
1032    }
1033
1034    if {${os.platform} == "darwin"} {
1035        system "niutil -create . /users/${name}"
1036        system "niutil -createprop . /users/${name} name ${name}"
1037        system "niutil -createprop . /users/${name} passwd ${passwd}"
1038        system "niutil -createprop . /users/${name} uid ${uid}"
1039        system "niutil -createprop . /users/${name} gid ${gid}"
1040        system "niutil -createprop . /users/${name} realname ${realname}"
1041        system "niutil -createprop . /users/${name} home ${home}"
1042        system "niutil -createprop . /users/${name} shell ${shell}"
1043    } else {
1044        # XXX adduser is only available for darwin, add more support here
1045        ui_warn "WARNING: adduser is not implemented on ${os.platform}."
1046        ui_warn "The requested user was not created."
1047    }
1048}
1049
1050proc addgroup {name args} {
1051    global os.platform
1052    set gid [nextgid]
1053    set passwd {\*}
1054    set users ""
1055
1056    foreach arg $args {
1057        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
1058            regsub -all " " ${val} "\\ " val
1059            set $key $val
1060        }
1061    }
1062
1063    if {[existsgroup ${name}] != 0 || [existsgroup ${gid}] != 0} {
1064        return
1065    }
1066
1067    if {${os.platform} == "darwin"} {
1068        system "niutil -create . /groups/${name}"
1069        system "niutil -createprop . /groups/${name} name ${name}"
1070        system "niutil -createprop . /groups/${name} gid ${gid}"
1071        system "niutil -createprop . /groups/${name} passwd ${passwd}"
1072        system "niutil -createprop . /groups/${name} users ${users}"
1073    } else {
1074        # XXX addgroup is only available for darwin, add more support here
1075        ui_warn "WARNING: addgroup is not implemented on ${os.platform}."
1076        ui_warn "The requested group was not created."
1077    }
1078}
Note: See TracBrowser for help on using the repository browser.