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

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

Remember to bring in the option_proc global. This will fix depends_*-append

  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 35.2 KB
Line 
1# ex: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
34
35global targets target_uniqid all_variants
36
37set targets [list]
38set target_uniqid 0
39
40set all_variants [list]
41
42########### External High Level Procedures ###########
43
44namespace eval options {
45}
46
47# options
48# Exports options in an array as externally callable procedures
49# Thus, "options name date" would create procedures named "name"
50# and "date" that set global variables "name" and "date", respectively
51# When an option is modified in any way, options::$option is called,
52# if it exists
53# Arguments: <list of options>
54proc options {args} {
55    foreach option $args {
56        eval "proc $option {args} \{ \n\
57            global ${option} user_options option_procs \n\
58                \if \{!\[info exists user_options(${option})\]\} \{ \n\
59                     set ${option} \$args \n\
60                         if \{\[info exists option_procs($option)\]\} \{ \n\
61                                foreach p \$option_procs($option) \{ \n\
62                                        eval \"\$p $option set \$args\" \n\
63                                \} \n\
64                         \} \n\
65                \} \n\
66        \}"
67       
68        eval "proc ${option}-delete {args} \{ \n\
69            global ${option} user_options option_procs \n\
70                \if \{!\[info exists user_options(${option})\]\} \{ \n\
71                    foreach val \$args \{ \n\
72                        ldelete ${option} \$val \n\
73                    \} \n\
74                    if \{\[string length \$${option}\] == 0\} \{ \n\
75                        unset ${option} \n\
76                    \} \n\
77                        if \{\[info exists option_procs($option)\]\} \{ \n\
78                            foreach p \$option_procs($option) \{ \n\
79                                eval \"\$p $option delete \$args\" \n\
80                        \} \n\
81                    \} \n\
82                \} \n\
83        \}"
84        eval "proc ${option}-append {args} \{ \n\
85            global ${option} user_options option_procs \n\
86                \if \{!\[info exists user_options(${option})\]\} \{ \n\
87                    if \{\[info exists ${option}\]\} \{ \n\
88                        set ${option} \[concat \$\{$option\} \$args\] \n\
89                    \} else \{ \n\
90                        set ${option} \$args \n\
91                    \} \n\
92                    if \{\[info exists option_procs($option)\]\} \{ \n\
93                        foreach p \$option_procs($option) \{ \n\
94                            eval \"\$p $option append \$args\" \n\
95                        \} \n\
96                    \} \n\
97                \} \n\
98        \}"
99    }
100}
101
102proc options_export {args} {
103    foreach option $args {
104        eval "proc options::${option} \{args\} \{ \n\
105            global ${option} PortInfo \n\
106            if \{\[info exists ${option}\]\} \{ \n\
107                set PortInfo(${option}) \$${option} \n\
108            \} else \{ \n\
109                unset PortInfo(${option}) \n\
110            \} \n\
111        \}"
112        option_proc ${option} options::${option}
113    }
114}
115
116proc option_proc {option args} {
117    global option_procs
118    eval "lappend option_procs($option) $args"
119}
120
121# commands
122# Accepts a list of arguments, of which several options are created
123# and used to form a standard set of command options.
124proc commands {args} {
125    foreach option $args {
126        options use_${option} ${option}.dir ${option}.pre_args ${option}.args ${option}.post_args ${option}.env ${option}.type ${option}.cmd
127    }
128}
129
130# command
131# Given a command name, command assembled a string
132# composed of the command options.
133proc command {command} {
134    global ${command}.dir ${command}.pre_args ${command}.args ${command}.post_args ${command}.env ${command}.type ${command}.cmd
135   
136    set cmdstring ""
137    if [info exists ${command}.dir] {
138        set cmdstring "cd [set ${command}.dir] &&"
139    }
140   
141    if [info exists ${command}.env] {
142        foreach string [set ${command}.env] {
143            set cmdstring "$cmdstring $string"
144        }
145    }
146   
147    if [info exists ${command}.cmd] {
148        foreach string [set ${command}.cmd] {
149            set cmdstring "$cmdstring $string"
150        }
151    } else {
152        set cmdstring "$cmdstring ${command}"
153    }
154    foreach var "${command}.pre_args ${command}.args ${command}.post_args" {
155        if [info exists $var] {
156            foreach string [set ${var}] {
157                set cmdstring "$cmdstring $string"
158            }
159        }
160    }
161    ui_debug "Assembled command: '$cmdstring'"
162    return $cmdstring
163}
164
165# default
166# Sets a variable to the supplied default if it does not exist,
167# and adds a variable trace. The variable traces allows for delayed
168# variable and command expansion in the variable's default value.
169proc default {option val} {
170    global $option option_defaults
171    if {[info exists option_defaults($option)]} {
172        ui_debug "Re-registering default for $option"
173    } else {
174        # If option is already set and we did not set it
175        # do not reset the value
176        if {[info exists $option]} {
177            return
178        }
179    }
180    set option_defaults($option) $val
181    set $option $val
182    trace variable $option rwu default_check
183}
184
185# default_check
186# trace handler to provide delayed variable & command expansion
187# for default variable values
188proc default_check {optionName index op} {
189    global option_defaults $optionName
190    switch $op {
191        w {
192            unset option_defaults($optionName)
193            trace vdelete $optionName rwu default_check
194            return
195        }
196        r {
197            upvar $optionName option
198            uplevel #0 set $optionName $option_defaults($optionName)
199            return
200        }
201        u {
202            unset option_defaults($optionName)
203            trace vdelete $optionName rwu default_check
204            return
205        }
206    }
207}
208
209# variant <provides> [<provides> ...] [requires <requires> [<requires>]]
210# Portfile level procedure to provide support for declaring variants
211proc variant {args} {
212    global all_variants PortInfo
213    upvar $args upargs
214   
215    set len [llength $args]
216    set code [lindex $args end]
217    set args [lrange $args 0 [expr $len - 2]]
218   
219    set obj [variant_new "temp-variant"]
220   
221    # mode indicates what the arg is interpreted as.
222        # possible mode keywords are: requires, conflicts, provides
223        # The default mode is provides.  Arguments are added to the
224        # most recently specified mode (left to right).
225    set mode "provides"
226    foreach arg $args {
227                switch -exact $arg {
228                        provides { set mode "provides" }
229                        requires { set mode "requires" }
230                        conflicts { set mode "conflicts" }
231                        default { $obj append $mode $arg }             
232        }
233    }
234    $obj set name "[join [$obj get provides] -]"
235
236    # make a user procedure named variant-blah-blah
237    # we will call this procedure during variant-run
238    makeuserproc "variant-[$obj get name]" \{$code\}
239    lappend all_variants $obj
240   
241    # Export provided variant to PortInfo
242    lappend PortInfo(variants) [$obj get provides]
243}
244
245# variant_isset name
246# Returns 1 if variant name selected, otherwise 0
247proc variant_isset {name} {
248    global variations
249   
250    if {[info exists variations($name)] && $variations($name) == "+"} {
251        return 1
252    }
253    return 0
254}
255
256# variant_set name
257# Sets variant to run for current portfile
258proc variant_set {name} {
259    global variations
260   
261    set variations($name) +
262}
263
264# variant_unset name
265# Clear variant for current portfile
266proc variant_unset {name} {
267    global variations
268
269    set variations($name) -
270}
271
272########### Misc Utility Functions ###########
273
274# tbool (testbool)
275# If the variable exists in the calling procedure's namespace
276# and is set to "yes", return 1. Otherwise, return 0
277proc tbool {key} {
278    upvar $key $key
279    if {[info exists $key]} {
280        if {[string equal -nocase [set $key] "yes"]} {
281            return 1
282        }
283    }
284    return 0
285}
286
287# ldelete
288# Deletes a value from the supplied list
289proc ldelete {list value} {
290    upvar $list uplist
291    set ix [lsearch -exact $uplist $value]
292    if {$ix >= 0} {
293        set uplist [lreplace $uplist $ix $ix]
294    }
295}
296
297# reinplace
298# Provides "sed in place" functionality
299proc reinplace {oddpattern file}  {
300    set backpattern [strsed $oddpattern {g/\//\\\\\//}]
301    set pattern [strsed $backpattern {g/\|/\//}]
302
303    if {[catch {set tmpfile [mktemp "/tmp/[file tail $file].sed.XXXXXXXX"]} error]} {
304        ui_error "reinplace: $error"
305        return -code error "reinplace failed"
306    }
307
308    if {[catch {exec sed $pattern < $file > $tmpfile} error]} {
309        ui_error "reinplace: $error"
310        file delete "$tmpfile"
311        return -code error "reinplace failed"
312    }
313
314    if {[catch {exec cp $tmpfile $file} error]} {
315        ui_error "reinplace: $error"
316        file delete "$tmpfile"
317        return -code error "reinplace failed"
318    }
319    file delete "$tmpfile"
320    return
321}
322
323# filefindbypath
324# Provides searching of the standard path for included files
325proc filefindbypath {fname} {
326    global distpath filedir workdir worksrcdir portpath
327
328    if [file readable $fname] {
329        return $fname
330    } elseif [file readable $portpath/$fname] {
331        return $portpath/$fname
332    } elseif [file readable $portpath/$filedir/$fname] {
333        return $portpath/$filedir/$fname
334    } elseif [file readable $distpath/$fname] {
335        return $distpath/$fname
336    } elseif [file readable $portpath/$workdir/$worksrcdir/$fname] {
337        return $portpath/$workdir/$worksrcdir/$fname
338    } elseif [file readable [file join /etc $fname]] {
339        return [file join /etc $fname]
340    }
341    return ""
342}
343
344# include
345# Source a file, looking for it along a standard search path.
346proc include {fname} {
347    set tgt [filefindbypath $fname]
348    if [string length $tgt] {
349        uplevel "source $tgt"
350    } else {
351        return -code error "Unable to find include file $fname"
352    }
353}
354
355# makeuserproc
356# This procedure re-writes the user-defined custom target to include
357# all the globals in its scope.  This is undeniably ugly, but I haven't
358# thought of any other way to do this.
359proc makeuserproc {name body} {
360    regsub -- "^\{(.*?)" $body "\{ \n foreach g \[info globals\] \{ \n global \$g \n \} \n \\1" body
361    eval "proc $name {} $body"
362}
363
364########### Internal Dependancy Manipulation Procedures ###########
365
366# returns a depspec by name
367proc dlist_get_by_name {dlist name} {
368    set result ""
369    foreach d $dlist {
370        if {[$d get name] == $name} {
371            set result $d
372            break
373        }
374    }
375    return $result
376}
377
378# returns a list of depspecs that contain the given name in the given key
379proc depspec_get_matches {dlist key value} {
380    set result [list]
381    foreach d $dlist {
382        foreach val [$d get $key] {
383            if {$val == $value} {
384                lappend result $d
385            }
386        }
387    }
388    return $result
389}
390
391# Count the unmet dependencies in the dlist based on the statusdict
392proc dlist_count_unmet {dlist statusdict names} {
393    upvar $statusdict upstatusdict
394    set unmet 0
395    foreach name $names {
396        # Service was provided, check next.
397        if {[info exists upstatusdict($name)] && $upstatusdict($name) == 1} {
398            continue
399        } else {
400            incr unmet
401        }
402    }
403    return $unmet
404}
405
406# Returns true if any of the dependencies are pending in the dlist
407proc dlist_has_pending {dlist uses} {
408    foreach name $uses {
409        if {[llength [depspec_get_matches $dlist provides $name]] > 0} {
410            return 1
411        }
412    }
413    return 0
414}
415
416# Get the name of the next eligible item from the dependency list
417proc generic_get_next {dlist statusdict} {
418    set nextitem ""
419    # arbitrary large number ~ INT_MAX
420    set minfailed 2000000000
421    upvar $statusdict upstatusdict
422   
423    foreach obj $dlist {               
424        # skip if unsatisfied hard dependencies
425        if {[dlist_count_unmet $dlist upstatusdict [$obj get requires]]} { continue }
426       
427        # favor item with fewest unment soft dependencies
428        set unmet [dlist_count_unmet $dlist upstatusdict [$obj get uses]]
429       
430        # delay items with unmet soft dependencies that can be filled
431        if {$unmet > 0 && [dlist_has_pending $dlist [$obj get uses]]} { continue }
432       
433        if {$unmet >= $minfailed} {
434            # not better than our last pick
435            continue
436        } else {
437            # better than our last pick
438            set minfailed $unmet
439            set nextitem $obj
440        }
441    }
442    return $nextitem
443}
444
445
446# Evaluate the list of depspecs, running each as it becomes eligible.
447# dlist is a collection of depspec objects to be run
448# get_next_proc is used to determine the best item to run
449proc dlist_evaluate {dlist get_next_proc} {
450    global portname
451   
452    # status - keys will be node names, values will be {-1, 0, 1}.
453    array set statusdict [list]
454   
455    # XXX: Do we want to evaluate this dynamically instead of statically?
456    foreach obj $dlist {
457        if {[$obj test] == 1} {
458            foreach name [$obj get provides] {
459                set statusdict($name) 1
460            }
461            ldelete dlist $obj
462        }
463    }
464   
465    # loop for as long as there are nodes in the dlist.
466    while (1) {
467        set obj [$get_next_proc $dlist statusdict]
468       
469        if {$obj == ""} { 
470            break
471        } else {
472            set result [$obj run]
473            # depspec->run returns an error code, so 0 == success.
474            # translate this to the statusdict notation where 1 == success.
475            foreach name [$obj get provides] {
476                set statusdict($name) [expr $result == 0]
477            }
478           
479            # Delete the item from the waiting list.
480            ldelete dlist $obj
481        }
482    }
483   
484    if {[llength $dlist] > 0} {
485        # somebody broke!
486        ui_info "Warning: the following items did not execute (for $portname): "
487        foreach obj $dlist {
488            ui_info "[$obj get name] " -nonewline
489        }
490        ui_info ""
491        return 1
492    }
493    return 0
494}
495
496proc target_run {this} {
497    global target_state_fd portname
498    set result 0
499    set procedure [$this get procedure]
500    if {$procedure != ""} {
501        set name [$this get name]
502       
503        if {[$this has init]} {
504            set result [catch {[$this get init] $name} errstr]
505        }
506       
507        if {[check_statefile target $name $target_state_fd]} {
508            set result 0
509            ui_debug "Skipping completed $name ($portname)"
510        } else {
511            # Execute pre-run procedure
512            if {[$this has prerun]} {
513                set result [catch {[$this get prerun] $name} errstr]
514            }
515           
516            if {$result == 0} {
517                foreach pre [$this get pre] {
518                    ui_debug "Executing $pre"
519                    set result [catch {$pre $name} errstr]
520                    if {$result != 0} { break }
521                }
522            }
523           
524            if {$result == 0} {
525                ui_debug "Executing $name ($portname)"
526                set result [catch {$procedure $name} errstr]
527            }
528           
529            if {$result == 0} {
530                foreach post [$this get post] {
531                    ui_debug "Executing $post"
532                    set result [catch {$post $name} errstr]
533                    if {$result != 0} { break }
534                }
535            }
536            # Execute post-run procedure
537            if {[$this has postrun] && $result == 0} {
538                set postrun [$this get postrun]
539                ui_debug "Executing $postrun"
540                set result [catch {$postrun $name} errstr]
541            }
542        }
543        if {$result == 0} {
544            if {[$this get runtype] != "always"} {
545                write_statefile target $name $target_state_fd
546            }
547        } else {
548            ui_error "Target error: $name returned: $errstr"
549            set result 1
550        }
551       
552    } else {
553        ui_info "Warning: $name does not have a registered procedure"
554        set result 1
555    }
556   
557    return $result
558}
559
560proc eval_targets {target} {
561    global targets target_state_fd
562    set dlist $targets
563   
564    # Select the subset of targets under $target
565    if {$target != ""} {
566        # XXX munge target. install really means registry, then install
567        # If more than one target ever needs this, make this a generic interface
568        if {$target == "install"} {
569            set target registry
570        }
571        set matches [depspec_get_matches $dlist provides $target]
572        if {[llength $matches] > 0} {
573            set dlist [dlist_append_dependents $dlist [lindex $matches 0] [list]]
574            # Special-case 'all'
575        } elseif {$target != "all"} {
576            ui_info "unknown target: $target"
577            return 1
578        }
579    }
580   
581    # Restore the state from a previous run.
582    set target_state_fd [open_statefile]
583   
584    set ret [dlist_evaluate $dlist generic_get_next]
585   
586    close $target_state_fd
587    return $ret
588}
589
590# returns the names of dependents of <name> from the <itemlist>
591proc dlist_append_dependents {dlist obj result} {
592   
593    # Append the item to the list, avoiding duplicates
594    if {[lsearch $result $obj] == -1} {
595        lappend result $obj
596    }
597   
598    # Recursively append any hard dependencies
599    foreach dep [$obj get requires] {
600        foreach provider [depspec_get_matches $dlist provides $dep] {
601            set result [dlist_append_dependents $dlist $provider $result]
602        }
603    }
604    # XXX: add soft-dependencies?
605    return $result
606}
607
608# open_statefile
609# open file to store name of completed targets
610proc open_statefile {args} {
611    global portpath workdir
612   
613    if ![file isdirectory $portpath/$workdir] {
614        file mkdir $portpath/$workdir
615    }
616    # flock Portfile
617    set statefile [file join $portpath $workdir .darwinports.state]
618    if {[file exists $statefile] && ![file writable $statefile]} {
619        return -code error "$statefile is not writable - check permission on port directory"
620    }
621    set fd [open $statefile a+]
622    if [catch {flock $fd -exclusive -noblock} result] {
623        if {"$result" == "EAGAIN"} {
624            ui_puts "Waiting for lock on $statefile"
625        } elseif {"$result" == "EOPNOTSUPP"} {
626            # Locking not supported, just return
627            return $fd
628        } else {
629            return -code error "$result obtaining lock on $statefile"
630        }
631    }
632    flock $fd -exclusive
633    return $fd
634}
635
636# check_statefile
637# Check completed/selected state of target/variant $name
638proc check_statefile {class name fd} {
639    global portpath workdir
640   
641    seek $fd 0
642    while {[gets $fd line] >= 0} {
643                if {$line == "$class: $name"} {
644                        return 1
645                }
646    }
647    return 0
648}
649
650# write_statefile
651# Set target $name completed in the state file
652proc write_statefile {class name fd} {
653    if {[check_statefile $class $name $fd]} {
654                return 0
655    }
656    seek $fd 0 end
657    puts $fd "$class: $name"
658    flush $fd
659}
660
661# check_statefile_variants
662# Check that recorded selection of variants match the current selection
663proc check_statefile_variants {variations fd} {
664        upvar $variations upvariations
665       
666    seek $fd 0
667    while {[gets $fd line] >= 0} {
668                if {[regexp "variant: (.*)" $line match name]} {
669                        set oldvariations([string range $name 1 end]) [string range $name 0 0]
670                }
671    }
672
673        set mismatch 0
674        if {[array size oldvariations] > 0} {
675                if {[array size oldvariations] != [array size upvariations]} {
676                        set mismatch 1
677                } else {
678                        foreach key [array names upvariations *] {
679                                if {$upvariations($key) != $oldvariations($key)} {
680                                        set mismatch 1
681                                        break
682                                }
683                        }
684                }
685        }
686
687        return $mismatch
688}
689
690# Traverse the ports collection hierarchy and call procedure func for
691# each directory containing a Portfile
692proc port_traverse {func {dir .}} {
693    set pwd [pwd]
694    if [catch {cd $dir} err] {
695        ui_error $err
696        return
697    }
698    foreach name [readdir .] {
699        if {[string match $name .] || [string match $name ..]} {
700            continue
701        }
702        if [file isdirectory $name] {
703            port_traverse $func $name
704        } else {
705            if [string match $name Portfile] {
706                catch {eval $func {[file join $pwd $dir]}}
707            }
708        }
709    }
710    cd $pwd
711}
712
713
714########### Port Variants ###########
715
716# Each variant which provides a subset of the requested variations
717# will be chosen.  Returns a list of the selected variants.
718proc choose_variants {dlist variations} {
719    upvar $variations upvariations
720   
721    set selected [list]
722   
723    foreach obj $dlist {
724        # Enumerate through the provides, tallying the pros and cons.
725        set pros 0
726        set cons 0
727        set ignored 0
728        foreach flavor [$obj get provides] {
729            if {[info exists upvariations($flavor)]} {
730                if {$upvariations($flavor) == "+"} {
731                    incr pros
732                } elseif {$upvariations($flavor) == "-"} {
733                    incr cons
734                }
735            } else {
736                incr ignored
737            }
738        }
739       
740        if {$cons > 0} { continue }
741       
742        if {$pros > 0 && $ignored == 0} {
743            lappend selected $obj
744        }
745    }
746    return $selected
747}
748
749proc variant_run {this} {
750    set name [$this get name]
751    ui_debug "Executing $name provides [$this get provides]"
752
753        # test for conflicting variants
754        foreach v [$this get conflicts] {
755                if {[variant_isset $v]} {
756                        ui_error "Variant $name conflicts with $v"
757                        return 1
758                }
759        }
760
761    # execute proc with same name as variant.
762    if {[catch "variant-${name}" result]} {
763        ui_error "Error executing $name: $result"
764        return 1
765    }
766    return 0
767}
768
769proc eval_variants {variations target} {
770    global all_variants ports_force
771    set dlist $all_variants
772        set result 0
773    upvar $variations upvariations
774    set chosen [choose_variants $dlist upvariations]
775   
776    # now that we've selected variants, change all provides [a b c] to [a-b-c]
777    # this will eliminate ambiguity between item a, b, and a-b while fulfilling requirments.
778    #foreach obj $dlist {
779    #    $obj set provides [list [join [$obj get provides] -]]
780    #}
781   
782    set newlist [list]
783    foreach variant $chosen {
784        set newlist [dlist_append_dependents $dlist $variant $newlist]
785    }
786   
787    dlist_evaluate $newlist generic_get_next
788       
789        # Make sure the variations match those stored in the statefile.
790        # If they don't match, print an error indicating a 'port clean'
791        # should be performed. 
792        # - Skip this test if the statefile is empty.
793        # - Skip this test if performing a clean.
794        # - Skip this test if ports_force was specified.
795
796        if {$target != "clean" && 
797                !([info exists ports_force] && $ports_force == "yes")} {
798                set state_fd [open_statefile]
799       
800                if {[check_statefile_variants upvariations $state_fd]} {
801                        ui_error "Requested variants do not match original selection.\nPlease perform 'port clean' or specify the force option."
802                        set result 1
803                } else {
804                        # Write variations out to the statefile
805                        foreach key [array names upvariations *] {
806                                write_statefile variant $upvariations($key)$key $state_fd
807                        }
808                }
809               
810                close $state_fd
811        }
812       
813        return $result
814}
815
816##### DEPSPEC #####
817
818# Object-Oriented Depspecs
819#
820# Each depspec will have its data stored in an array
821# (indexed by field name) and its procedures will be
822# called via the dispatch procedure that is returned
823# from depspec_new.
824#
825# sample usage:
826# set obj [depspec_new]
827# $obj set name "hello"
828#
829
830# Depspec
831#       str name
832#       str provides[]
833#       str requires[]
834#       str uses[]
835
836global depspec_uniqid
837set depspec_uniqid 0
838
839# Depspec class definition.
840global depspec_vtbl
841set depspec_vtbl(test) depspec_test
842set depspec_vtbl(run) depspec_run
843set depspec_vtbl(get) depspec_get
844set depspec_vtbl(set) depspec_set
845set depspec_vtbl(has) depspec_has
846set depspec_vtbl(append) depspec_append
847
848# constructor for abstract depspec class
849proc depspec_new {name} {
850    global depspec_uniqid
851    set id [incr depspec_uniqid]
852   
853    # declare the array of data
854    set data dpspc_data_${id}
855    set disp dpspc_disp_${id}
856   
857    global $data 
858    set ${data}(name) $name
859    set ${data}(_vtbl) depspec_vtbl
860   
861    eval "proc $disp {method args} { \n \
862                        global $data \n \
863                        eval return \\\[depspec_dispatch $disp $data \$method \$args\\\] \n \
864                }"
865   
866    return $disp
867}
868
869proc depspec_get {this prop} {
870    set data [$this _data]
871    global $data
872    if {[eval info exists ${data}($prop)]} {
873        eval return $${data}($prop)
874    } else {
875        return ""
876    }
877}
878
879proc depspec_set {this prop args} {
880    set data [$this _data]
881    global $data
882    eval "set ${data}($prop) \"$args\""
883}
884
885proc depspec_has {this prop} {
886    set data [$this _data]
887    global $data
888    eval return \[info exists ${data}($prop)\]
889}
890
891proc depspec_append {this prop args} {
892    set data [$this _data]
893    global $data
894    set vals [join $args " "]
895    eval lappend ${data}($prop) $vals
896}
897
898# is the only proc to get direct access to the object's data
899# so the _data accessor has to be defined here.  all other
900# methods are looked up in the virtual function table,
901# and are called with {$this $args}.
902proc depspec_dispatch {this data method args} {
903    global $data
904    if {$method == "_data"} { return $data }
905    eval set vtbl $${data}(_vtbl)
906    global $vtbl
907    if {[info exists ${vtbl}($method)]} {
908        eval set function $${vtbl}($method)
909        eval "return \[$function $this $args\]"
910    } else {
911        ui_error "unknown method: $method"
912    }
913    return ""
914}
915
916proc depspec_test {this} {
917    return 0
918}
919
920proc depspec_run {this} {
921    return 0
922}
923
924##### target depspec subclass #####
925
926# Target class definition.
927global target_vtbl
928array set target_vtbl [array get depspec_vtbl]
929set target_vtbl(run) target_run
930set target_vtbl(provides) target_provides
931set target_vtbl(requires) target_requires
932set target_vtbl(uses) target_uses
933set target_vtbl(deplist) target_deplist
934set target_vtbl(prerun) target_prerun
935set target_vtbl(postrun) target_postrun
936
937# constructor for target depspec class
938proc target_new {name procedure} {
939    global targets
940    set obj [depspec_new $name]
941   
942    $obj set _vtbl target_vtbl
943    $obj set procedure $procedure
944   
945    lappend targets $obj
946   
947    return $obj
948}
949
950proc target_provides {this args} {
951    global targets
952    # Register the pre-/post- hooks for use in Portfile.
953    # Portfile syntax: pre-fetch { puts "hello world" }
954    # User-code exceptions are caught and returned as a result of the target.
955    # Thus if the user code breaks, dependent targets will not execute.
956    foreach target $args {
957        set origproc [$this get procedure]
958        set ident [$this get name]
959        if {[info commands $target] != ""} {
960            ui_debug "[$this get name] attempted to register provides \'$target\' which is a pre-existing procedure. The target override procedure \'$target\' will not be provided"
961        } else {
962                eval "proc $target {args} \{ \n\
963                        $this set procedure proc-${ident}-${target}
964                        eval \"proc proc-${ident}-${target} \{name\} \{ \n\
965                                if \{\\\[catch userproc-${ident}-${target} result\\\]\} \{ \n\
966                                        ui_info \\\$result \n\
967                                        return 1 \n\
968                                \} else \{ \n\
969                                        return 0 \n\
970                                \} \n\
971                        \}\" \n\
972                        eval \"proc do-$target \{\} \{ $origproc $target\}\" \n\
973                        makeuserproc userproc-${ident}-${target} \$args \n\
974                \}"
975        }
976        eval "proc pre-$target {args} \{ \n\
977                        $this append pre proc-pre-${ident}-${target}
978                        eval \"proc proc-pre-${ident}-${target} \{name\} \{ \n\
979                                if \{\\\[catch userproc-pre-${ident}-${target} result\\\]\} \{ \n\
980                                        ui_info \\\$result \n\
981                                        return 1 \n\
982                                \} else \{ \n\
983                                        return 0 \n\
984                                \} \n\
985                        \}\" \n\
986                        makeuserproc userproc-pre-${ident}-${target} \$args \n\
987                \}"
988        eval "proc post-$target {args} \{ \n\
989                        $this append post proc-post-${ident}-${target}
990                        eval \"proc proc-post-${ident}-${target} \{name\} \{ \n\
991                                if \{\\\[catch userproc-post-${ident}-${target} result\\\]\} \{ \n\
992                                        ui_info \\\$result \n\
993                                        return 1 \n\
994                                \} else \{ \n\
995                                        return 0 \n\
996                                \} \n\
997                        \}\" \n\
998                        makeuserproc userproc-post-${ident}-${target} \$args \n\
999                \}"
1000    }
1001    eval "depspec_append $this provides $args"
1002}
1003
1004proc target_requires {this args} {
1005    eval "depspec_append $this requires $args"
1006}
1007
1008proc target_uses {this args} {
1009    eval "depspec_append $this uses $args"
1010}
1011
1012proc target_deplist {this args} {
1013    eval "depspec_append $this deplist $args"
1014}
1015
1016proc target_prerun {this args} {
1017    eval "depspec_append $this prerun $args"
1018}
1019
1020proc target_postrun {this args} {
1021    eval "depspec_append $this postrun $args"
1022}
1023
1024##### variant depspec subclass #####
1025
1026# Variant class definition.
1027global variant_vtbl
1028array set variant_vtbl [array get depspec_vtbl]
1029set variant_vtbl(run) variant_run
1030
1031# constructor for target depspec class
1032proc variant_new {name} {
1033    set obj [depspec_new $name]
1034   
1035    $obj set _vtbl variant_vtbl
1036   
1037    return $obj
1038}
1039
1040proc handle_default_variants {option action args} {
1041    global variations
1042    switch -regex $action {
1043        set|append {
1044            foreach v $args {
1045                if {[regexp {([-+])([-A-Za-z0-9_]+)} $v whole val variant]} {
1046                    if {![info exists variations($variant)]} {
1047                        set variations($variant) $val
1048                    }
1049                }
1050            }
1051        }
1052        delete {
1053            # xxx
1054        }
1055    }
1056}
1057
1058##### portfile depspec subclass #####
1059global portfile_vtbl
1060array set portfile_vtbl [array get depspec_vtbl]
1061set portfile_vtbl(run) portfile_run
1062set portfile_vtbl(test) portfile_test
1063
1064proc portfile_new {name} {
1065    set obj [depspec_new $name]
1066   
1067    $obj set _vtbl portfile_vtbl
1068   
1069    return $obj
1070}
1071
1072# jkh uses this API so i guess it's public =)
1073# builds the specified port (looked up in the index) to the specified target
1074# doesn't yet support options or variants...
1075proc portexec {portname target} {
1076    ui_debug "Executing $target ($portname)"
1077    array set options [list]
1078    array set variations [list]
1079    set res [dportsearch ^$portname\$]
1080    if {[llength $res] < 2} {
1081        ui_error "Portfile $portname not found"
1082        return -1
1083    }
1084        array set portinfo [lindex $res 1]
1085    set porturl $portinfo(porturl)
1086   
1087    set worker [dportopen $porturl options variations]
1088    if {[catch {dportexec $worker clean} result] || $result != 0} {
1089        ui_error "Clean of $portname failed: $result"
1090        dportclose $worker
1091        return -1
1092    }
1093        if {$target != "clean"} {
1094                if {[catch {dportexec $worker $target} result] || $result != 0} {
1095                ui_error "Execution $portname $target failed: $result"
1096                dportclose $worker
1097                return -1
1098                }
1099        }
1100    dportclose $worker
1101   
1102    return 0
1103}
1104
1105# build the specified portfile
1106proc portfile_run {this} {
1107    set portname [$this get name]
1108        if {[portexec $portname install] == 0} {
1109                portexec $portname clean
1110    }
1111}
1112
1113proc portfile_test {this} {
1114    set receipt [registry_exists [$this get name]]
1115    if {$receipt != ""} {
1116        ui_debug "Found Dependency: receipt: $receipt"
1117        return 1
1118    } else {
1119        return 0
1120    }
1121}
1122
1123proc portfile_search_path {depregex search_path} {
1124    set found 0
1125    foreach path $search_path {
1126        if {![file isdirectory $path]} {
1127            continue
1128        }
1129        foreach filename [readdir $path] {
1130            if {[regexp $depregex $filename] == 1} {
1131                ui_debug "Found Dependency: path: $path filename: $filename regex: $depregex"
1132                set found 1
1133                break
1134            }
1135        }
1136    }
1137    return $found
1138}
1139
1140
1141
1142##### lib portfile depspec subclass #####
1143# Search registry, then library path for regex
1144global libportfile_vtbl
1145array set libportfile_vtbl [array get portfile_vtbl]
1146set libportfile_vtbl(test) libportfile_test
1147
1148proc libportfile_new {name match} {
1149    set obj [portfile_new $name]
1150   
1151    $obj set _vtbl libportfile_vtbl
1152    $obj set depregex $match
1153   
1154    return $obj
1155}
1156
1157# XXX - Architecture specific
1158# XXX - Rely on information from internal defines in cctools/dyld:
1159# define DEFAULT_FALLBACK_FRAMEWORK_PATH
1160# /Library/Frameworks:/Library/Frameworks:/Network/Library/Frameworks:/System/Library/Frameworks
1161# define DEFAULT_FALLBACK_LIBRARY_PATH /lib:/usr/local/lib:/lib:/usr/lib
1162# Environment variables DYLD_FRAMEWORK_PATH, DYLD_LIBRARY_PATH,
1163# DYLD_FALLBACK_FRAMEWORK_PATH, and DYLD_FALLBACK_LIBRARY_PATH take precedence
1164
1165proc libportfile_test {this} {
1166    global env prefix
1167   
1168    # Check the registry first
1169    set result [portfile_test $this]
1170    if {$result == 1} {
1171        return $result
1172    } else {
1173        # Not in the registry, check the library path.
1174        set depregex [$this get depregex]
1175       
1176        if {[info exists env(DYLD_FRAMEWORK_PATH)]} {
1177            lappend search_path $env(DYLD_FRAMEWORK_PATH)
1178        } else {
1179            lappend search_path /Library/Frameworks /Network/Library/Frameworks /System/Library/Frameworks
1180        }
1181        if {[info exists env(DYLD_FALLBACK_FRAMEWORK_PATH)]} {
1182            lappend search_path $env(DYLD_FALLBACK_FRAMEWORK_PATH)
1183        }
1184        if {[info exists env(DYLD_LIBRARY_PATH)]} {
1185            lappend search_path $env(DYLD_LIBRARY_PATH)
1186        } else {
1187            lappend search_path /lib /usr/local/lib /lib /usr/lib /op/local/lib /usr/X11R6/lib ${prefix}/lib
1188        }
1189        if {[info exists env(DYLD_FALLBACK_LIBRARY_PATH)]} {
1190            lappend search_path $env(DYLD_LIBRARY_PATH)
1191        }
1192        regsub {\.} $depregex {\.} depregex
1193        set depregex \^$depregex.*\\.dylib\$
1194       
1195        return [portfile_search_path $depregex $search_path]
1196    }
1197}
1198
1199##### bin portfile depspec subclass #####
1200# Search registry, then binary path for regex
1201global binportfile_vtbl
1202array set binportfile_vtbl [array get portfile_vtbl]
1203set binportfile_vtbl(test) binportfile_test
1204
1205proc binportfile_new {name match} {
1206    set obj [portfile_new $name]
1207   
1208    $obj set _vtbl binportfile_vtbl
1209    $obj set depregex $match
1210   
1211    return $obj
1212}
1213
1214proc binportfile_test {this} {
1215    global env prefix
1216   
1217    # Check the registry first
1218    set result [portfile_test $this]
1219    if {$result == 1} {
1220        return $result
1221    } else {
1222        # Not in the registry, check the binary path.
1223        set depregex [$this get depregex]
1224       
1225        set search_path [split $env(PATH) :]
1226       
1227        set depregex \^$depregex\$
1228       
1229        return [portfile_search_path $depregex $search_path]
1230    }
1231}
1232
1233##### path portfile depspec subclass #####
1234# Search registry, then search specified absolute or
1235# ${prefix} relative path for regex
1236global pathportfile_vtbl
1237array set pathportfile_vtbl [array get portfile_vtbl]
1238set pathportfile_vtbl(test) pathportfile_test
1239
1240proc pathportfile_new {name match} {
1241    set obj [portfile_new $name]
1242   
1243    $obj set _vtbl pathportfile_vtbl
1244    $obj set depregex $match
1245    return $obj
1246}
1247
1248proc pathportfile_test {this} {
1249    global env prefix
1250   
1251    # Check the registry first
1252    set result [portfile_test $this]
1253    if {$result == 1} {
1254        return $result
1255    } else {
1256        # Not in the registry, check the path.
1257        # separate directory from regex
1258        set fullname [$this get depregex]
1259
1260        regexp {^(.*)/(.*?)$} "$fullname" match search_path depregex
1261
1262        if {[string index $search_path 0] != "/"} {
1263                # Prepend prefix if not an absolute path
1264                set search_path "${prefix}/${search_path}"
1265        }
1266               
1267        set depregex \^$depregex\$
1268       
1269        return [portfile_search_path $depregex $search_path]
1270    }
1271}
1272
1273proc adduser {name args} {
1274    global os.platform
1275    set passwd {\*}
1276    set uid [nextuid]
1277    set gid [existsgroup nogroup]
1278    set realname ${name}
1279    set home /dev/null
1280    set shell /dev/null
1281
1282    foreach arg $args {
1283        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
1284            regsub -all " " ${val} "\\ " val
1285            set $key $val
1286        }
1287    }
1288
1289    if {[existsuser ${name}] != 0 || [existsuser ${uid}] != 0} {
1290        return
1291    }
1292
1293    if {${os.platform} == "darwin"} {
1294        system "niutil -create . /users/${name}"
1295        system "niutil -createprop . /users/${name} name ${name}"
1296        system "niutil -createprop . /users/${name} passwd ${passwd}"
1297        system "niutil -createprop . /users/${name} uid ${uid}"
1298        system "niutil -createprop . /users/${name} gid ${gid}"
1299        system "niutil -createprop . /users/${name} realname ${realname}"
1300        system "niutil -createprop . /users/${name} home ${home}"
1301        system "niutil -createprop . /users/${name} shell ${shell}"
1302    } else {
1303        # XXX adduser is only available for darwin, add more support here
1304        ui_warning "WARNING: adduser is not implemented on ${os.platform}."
1305        ui_warning "The requested user was not created."
1306    }
1307}
1308
1309proc addgroup {name args} {
1310    global os.platform
1311    set gid [nextgid]
1312    set passwd {\*}
1313    set users ""
1314
1315    foreach arg $args {
1316        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
1317            regsub -all " " ${val} "\\ " val
1318            set $key $val
1319        }
1320    }
1321
1322    if {[existsgroup ${name}] != 0 || [existsgroup ${gid}] != 0} {
1323        return
1324    }
1325
1326    if {${os.platform} == "darwin"} {
1327        system "niutil -create . /groups/${name}"
1328        system "niutil -createprop . /groups/${name} name ${name}"
1329        system "niutil -createprop . /groups/${name} gid ${gid}"
1330        system "niutil -createprop . /groups/${name} passwd ${passwd}"
1331        system "niutil -createprop . /groups/${name} users ${users}"
1332    } else {
1333        # XXX addgroup is only available for darwin, add more support here
1334        ui_warning "WARNING: addgroup is not implemented on ${os.platform}."
1335        ui_warning "The requested group was not created."
1336    }
1337}
Note: See TracBrowser for help on using the repository browser.