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

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

Store variants in state file. Print error if state exists with different
set of variants.

  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 34.8 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 \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 \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
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.  Skip this test if the statefile is empty.
792        # Also skip this test if performing a clean so we don't shoot
793        # ourselves in the foot.
794
795        if {$target != "clean"} {
796                set state_fd [open_statefile]
797       
798                if {[check_statefile_variants upvariations $state_fd]} {
799                        ui_error "Requested variants do not match original selection.\nPlease perform 'port clean'."
800                        set result 1
801                } else {
802                        # Write variations out to the statefile
803                        foreach key [array names upvariations *] {
804                                write_statefile variant $upvariations($key)$key $state_fd
805                        }
806                }
807               
808                close $state_fd
809        }
810       
811        return $result
812}
813
814##### DEPSPEC #####
815
816# Object-Oriented Depspecs
817#
818# Each depspec will have its data stored in an array
819# (indexed by field name) and its procedures will be
820# called via the dispatch procedure that is returned
821# from depspec_new.
822#
823# sample usage:
824# set obj [depspec_new]
825# $obj set name "hello"
826#
827
828# Depspec
829#       str name
830#       str provides[]
831#       str requires[]
832#       str uses[]
833
834global depspec_uniqid
835set depspec_uniqid 0
836
837# Depspec class definition.
838global depspec_vtbl
839set depspec_vtbl(test) depspec_test
840set depspec_vtbl(run) depspec_run
841set depspec_vtbl(get) depspec_get
842set depspec_vtbl(set) depspec_set
843set depspec_vtbl(has) depspec_has
844set depspec_vtbl(append) depspec_append
845
846# constructor for abstract depspec class
847proc depspec_new {name} {
848    global depspec_uniqid
849    set id [incr depspec_uniqid]
850   
851    # declare the array of data
852    set data dpspc_data_${id}
853    set disp dpspc_disp_${id}
854   
855    global $data 
856    set ${data}(name) $name
857    set ${data}(_vtbl) depspec_vtbl
858   
859    eval "proc $disp {method args} { \n \
860                        global $data \n \
861                        eval return \\\[depspec_dispatch $disp $data \$method \$args\\\] \n \
862                }"
863   
864    return $disp
865}
866
867proc depspec_get {this prop} {
868    set data [$this _data]
869    global $data
870    if {[eval info exists ${data}($prop)]} {
871        eval return $${data}($prop)
872    } else {
873        return ""
874    }
875}
876
877proc depspec_set {this prop args} {
878    set data [$this _data]
879    global $data
880    eval "set ${data}($prop) \"$args\""
881}
882
883proc depspec_has {this prop} {
884    set data [$this _data]
885    global $data
886    eval return \[info exists ${data}($prop)\]
887}
888
889proc depspec_append {this prop args} {
890    set data [$this _data]
891    global $data
892    set vals [join $args " "]
893    eval lappend ${data}($prop) $vals
894}
895
896# is the only proc to get direct access to the object's data
897# so the _data accessor has to be defined here.  all other
898# methods are looked up in the virtual function table,
899# and are called with {$this $args}.
900proc depspec_dispatch {this data method args} {
901    global $data
902    if {$method == "_data"} { return $data }
903    eval set vtbl $${data}(_vtbl)
904    global $vtbl
905    if {[info exists ${vtbl}($method)]} {
906        eval set function $${vtbl}($method)
907        eval "return \[$function $this $args\]"
908    } else {
909        ui_error "unknown method: $method"
910    }
911    return ""
912}
913
914proc depspec_test {this} {
915    return 0
916}
917
918proc depspec_run {this} {
919    return 0
920}
921
922##### target depspec subclass #####
923
924# Target class definition.
925global target_vtbl
926array set target_vtbl [array get depspec_vtbl]
927set target_vtbl(run) target_run
928set target_vtbl(provides) target_provides
929set target_vtbl(requires) target_requires
930set target_vtbl(uses) target_uses
931set target_vtbl(deplist) target_deplist
932set target_vtbl(prerun) target_prerun
933set target_vtbl(postrun) target_postrun
934
935# constructor for target depspec class
936proc target_new {name procedure} {
937    global targets
938    set obj [depspec_new $name]
939   
940    $obj set _vtbl target_vtbl
941    $obj set procedure $procedure
942   
943    lappend targets $obj
944   
945    return $obj
946}
947
948proc target_provides {this args} {
949    global targets
950    # Register the pre-/post- hooks for use in Portfile.
951    # Portfile syntax: pre-fetch { puts "hello world" }
952    # User-code exceptions are caught and returned as a result of the target.
953    # Thus if the user code breaks, dependent targets will not execute.
954    foreach target $args {
955        if {[info commands $target] != ""} {
956            ui_error "$name attempted to register provide \'$target\' which is a pre-existing procedure. Ignoring register."
957            continue;
958        }
959        set origproc [$this get procedure]
960        set ident [$this get name]
961        eval "proc $target {args} \{ \n\
962                        $this set procedure proc-${ident}-${target}
963                        eval \"proc proc-${ident}-${target} \{name\} \{ \n\
964                                if \{\\\[catch userproc-${ident}-${target} result\\\]\} \{ \n\
965                                        ui_info \\\$result \n\
966                                        return 1 \n\
967                                \} else \{ \n\
968                                        return 0 \n\
969                                \} \n\
970                        \}\" \n\
971                        eval \"proc do-$target \{\} \{ $origproc $target\}\" \n\
972                        makeuserproc userproc-${ident}-${target} \$args \n\
973                \}"
974        eval "proc pre-$target {args} \{ \n\
975                        $this append pre proc-pre-${ident}-${target}
976                        eval \"proc proc-pre-${ident}-${target} \{name\} \{ \n\
977                                if \{\\\[catch userproc-pre-${ident}-${target} result\\\]\} \{ \n\
978                                        ui_info \\\$result \n\
979                                        return 1 \n\
980                                \} else \{ \n\
981                                        return 0 \n\
982                                \} \n\
983                        \}\" \n\
984                        makeuserproc userproc-pre-${ident}-${target} \$args \n\
985                \}"
986        eval "proc post-$target {args} \{ \n\
987                        $this append post proc-post-${ident}-${target}
988                        eval \"proc proc-post-${ident}-${target} \{name\} \{ \n\
989                                if \{\\\[catch userproc-post-${ident}-${target} result\\\]\} \{ \n\
990                                        ui_info \\\$result \n\
991                                        return 1 \n\
992                                \} else \{ \n\
993                                        return 0 \n\
994                                \} \n\
995                        \}\" \n\
996                        makeuserproc userproc-post-${ident}-${target} \$args \n\
997                \}"
998    }
999    eval "depspec_append $this provides $args"
1000}
1001
1002proc target_requires {this args} {
1003    eval "depspec_append $this requires $args"
1004}
1005
1006proc target_uses {this args} {
1007    eval "depspec_append $this uses $args"
1008}
1009
1010proc target_deplist {this args} {
1011    eval "depspec_append $this deplist $args"
1012}
1013
1014proc target_prerun {this args} {
1015    eval "depspec_append $this prerun $args"
1016}
1017
1018proc target_postrun {this args} {
1019    eval "depspec_append $this postrun $args"
1020}
1021
1022##### variant depspec subclass #####
1023
1024# Variant class definition.
1025global variant_vtbl
1026array set variant_vtbl [array get depspec_vtbl]
1027set variant_vtbl(run) variant_run
1028
1029# constructor for target depspec class
1030proc variant_new {name} {
1031    set obj [depspec_new $name]
1032   
1033    $obj set _vtbl variant_vtbl
1034   
1035    return $obj
1036}
1037
1038proc handle_default_variants {option action args} {
1039    global variations
1040    switch -regex $action {
1041        set|append {
1042            foreach v $args {
1043                if {[regexp {([-+])([-A-Za-z0-9_]+)} $v whole val variant]} {
1044                    if {![info exists variations($variant)]} {
1045                        set variations($variant) $val
1046                    }
1047                }
1048            }
1049        }
1050        delete {
1051            # xxx
1052        }
1053    }
1054}
1055
1056##### portfile depspec subclass #####
1057global portfile_vtbl
1058array set portfile_vtbl [array get depspec_vtbl]
1059set portfile_vtbl(run) portfile_run
1060set portfile_vtbl(test) portfile_test
1061
1062proc portfile_new {name} {
1063    set obj [depspec_new $name]
1064   
1065    $obj set _vtbl portfile_vtbl
1066   
1067    return $obj
1068}
1069
1070# build the specified portfile
1071proc portfile_run {this} {
1072    set portname [$this get name]
1073   
1074    ui_debug "Building $portname"
1075    array set options [list]
1076    array set variations [list]
1077    array set portinfo [dportmatch ^$portname\$]
1078    if {[array size portinfo] == 0} {
1079        ui_error "Dependency $portname not found"
1080        return -1
1081    }
1082    set porturl $portinfo(porturl)
1083   
1084    set worker [dportopen $porturl options variations]
1085    if {[catch {dportexec $worker clean} result] || $result != 0} {
1086        ui_error "Clean of $portname before build failed: $result"
1087        dportclose $worker
1088        return -1
1089    }
1090    if {[catch {dportexec $worker install} result] || $result != 0} {
1091        ui_error "Build of $portname failed: $result"
1092        dportclose $worker
1093        return -1
1094    }
1095    if {[catch {dportexec $worker clean} result] || $result != 0} {
1096        ui_error "Clean of $portname after build failed: $result"
1097    }
1098    dportclose $worker
1099   
1100    return 0
1101}
1102
1103proc portfile_test {this} {
1104    set receipt [registry_exists [$this get name]]
1105    if {$receipt != ""} {
1106        ui_debug "Found Dependency: receipt: $receipt"
1107        return 1
1108    } else {
1109        return 0
1110    }
1111}
1112
1113proc portfile_search_path {depregex search_path} {
1114    set found 0
1115    foreach path $search_path {
1116        if {![file isdirectory $path]} {
1117            continue
1118        }
1119        foreach filename [readdir $path] {
1120            if {[regexp $depregex $filename] == 1} {
1121                ui_debug "Found Dependency: path: $path filename: $filename regex: $depregex"
1122                set found 1
1123                break
1124            }
1125        }
1126    }
1127    return $found
1128}
1129
1130
1131
1132##### lib portfile depspec subclass #####
1133# Search registry, then library path for regex
1134global libportfile_vtbl
1135array set libportfile_vtbl [array get portfile_vtbl]
1136set libportfile_vtbl(test) libportfile_test
1137
1138proc libportfile_new {name match} {
1139    set obj [portfile_new $name]
1140   
1141    $obj set _vtbl libportfile_vtbl
1142    $obj set depregex $match
1143   
1144    return $obj
1145}
1146
1147# XXX - Architecture specific
1148# XXX - Rely on information from internal defines in cctools/dyld:
1149# define DEFAULT_FALLBACK_FRAMEWORK_PATH
1150# /Library/Frameworks:/Library/Frameworks:/Network/Library/Frameworks:/System/Library/Frameworks
1151# define DEFAULT_FALLBACK_LIBRARY_PATH /lib:/usr/local/lib:/lib:/usr/lib
1152# Environment variables DYLD_FRAMEWORK_PATH, DYLD_LIBRARY_PATH,
1153# DYLD_FALLBACK_FRAMEWORK_PATH, and DYLD_FALLBACK_LIBRARY_PATH take precedence
1154
1155proc libportfile_test {this} {
1156    global env prefix
1157   
1158    # Check the registry first
1159    set result [portfile_test $this]
1160    if {$result == 1} {
1161        return $result
1162    } else {
1163        # Not in the registry, check the library path.
1164        set depregex [$this get depregex]
1165       
1166        if {[info exists env(DYLD_FRAMEWORK_PATH)]} {
1167            lappend search_path $env(DYLD_FRAMEWORK_PATH)
1168        } else {
1169            lappend search_path /Library/Frameworks /Network/Library/Frameworks /System/Library/Frameworks
1170        }
1171        if {[info exists env(DYLD_FALLBACK_FRAMEWORK_PATH)]} {
1172            lappend search_path $env(DYLD_FALLBACK_FRAMEWORK_PATH)
1173        }
1174        if {[info exists env(DYLD_LIBRARY_PATH)]} {
1175            lappend search_path $env(DYLD_LIBRARY_PATH)
1176        } else {
1177            lappend search_path /lib /usr/local/lib /lib /usr/lib /op/local/lib /usr/X11R6/lib ${prefix}/lib
1178        }
1179        if {[info exists env(DYLD_FALLBACK_LIBRARY_PATH)]} {
1180            lappend search_path $env(DYLD_LIBRARY_PATH)
1181        }
1182        regsub {\.} $depregex {\.} depregex
1183        set depregex \^$depregex.*\\.dylib\$
1184       
1185        return [portfile_search_path $depregex $search_path]
1186    }
1187}
1188
1189##### bin portfile depspec subclass #####
1190# Search registry, then binary path for regex
1191global binportfile_vtbl
1192array set binportfile_vtbl [array get portfile_vtbl]
1193set binportfile_vtbl(test) binportfile_test
1194
1195proc binportfile_new {name match} {
1196    set obj [portfile_new $name]
1197   
1198    $obj set _vtbl binportfile_vtbl
1199    $obj set depregex $match
1200   
1201    return $obj
1202}
1203
1204proc binportfile_test {this} {
1205    global env prefix
1206   
1207    # Check the registry first
1208    set result [portfile_test $this]
1209    if {$result == 1} {
1210        return $result
1211    } else {
1212        # Not in the registry, check the binary path.
1213        set depregex [$this get depregex]
1214       
1215        set search_path [split $env(PATH) :]
1216       
1217        set depregex \^$depregex\$
1218       
1219        return [portfile_search_path $depregex $search_path]
1220    }
1221}
1222
1223##### path portfile depspec subclass #####
1224# Search registry, then search specified absolute or
1225# ${prefix} relative path for regex
1226global pathportfile_vtbl
1227array set pathportfile_vtbl [array get portfile_vtbl]
1228set pathportfile_vtbl(test) pathportfile_test
1229
1230proc pathportfile_new {name match} {
1231    set obj [portfile_new $name]
1232   
1233    $obj set _vtbl pathportfile_vtbl
1234    $obj set depregex $match
1235    return $obj
1236}
1237
1238proc pathportfile_test {this} {
1239    global env prefix
1240   
1241    # Check the registry first
1242    set result [portfile_test $this]
1243    if {$result == 1} {
1244        return $result
1245    } else {
1246        # Not in the registry, check the path.
1247        # separate directory from regex
1248        set fullname [$this get depregex]
1249
1250        regexp {^(.*)/(.*?)$} "$fullname" match search_path depregex
1251
1252        if {[string index $search_path 0] != "/"} {
1253                # Prepend prefix if not an absolute path
1254                set search_path "${prefix}/${search_path}"
1255        }
1256               
1257        set depregex \^$depregex\$
1258       
1259        return [portfile_search_path $depregex $search_path]
1260    }
1261}
1262
1263proc adduser {name args} {
1264    global os.platform
1265    set passwd {\*}
1266    set uid [nextuid]
1267    set gid [existsgroup nogroup]
1268    set realname ${name}
1269    set home /dev/null
1270    set shell /dev/null
1271
1272    foreach arg $args {
1273        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
1274            regsub -all " " ${val} "\\ " val
1275            set $key $val
1276        }
1277    }
1278
1279    if {[existsuser ${name}] != 0 || [existsuser ${uid}] != 0} {
1280        return
1281    }
1282
1283    if {${os.platform} == "darwin"} {
1284        system "niutil -create . /users/${name}"
1285        system "niutil -createprop . /users/${name} name ${name}"
1286        system "niutil -createprop . /users/${name} passwd ${passwd}"
1287        system "niutil -createprop . /users/${name} uid ${uid}"
1288        system "niutil -createprop . /users/${name} gid ${gid}"
1289        system "niutil -createprop . /users/${name} realname ${realname}"
1290        system "niutil -createprop . /users/${name} home ${home}"
1291        system "niutil -createprop . /users/${name} shell ${shell}"
1292    } else {
1293        # XXX adduser is only available for darwin, add more support here
1294        ui_warning "WARNING: adduser is not implemented on ${os.platform}."
1295        ui_warning "The requested user was not created."
1296    }
1297}
1298
1299proc addgroup {name args} {
1300    global os.platform
1301    set gid [nextgid]
1302    set passwd {\*}
1303    set users ""
1304
1305    foreach arg $args {
1306        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
1307            regsub -all " " ${val} "\\ " val
1308            set $key $val
1309        }
1310    }
1311
1312    if {[existsgroup ${name}] != 0 || [existsgroup ${gid}] != 0} {
1313        return
1314    }
1315
1316    if {${os.platform} == "darwin"} {
1317        system "niutil -create . /groups/${name}"
1318        system "niutil -createprop . /groups/${name} name ${name}"
1319        system "niutil -createprop . /groups/${name} gid ${gid}"
1320        system "niutil -createprop . /groups/${name} passwd ${passwd}"
1321        system "niutil -createprop . /groups/${name} users ${users}"
1322    } else {
1323        # XXX addgroup is only available for darwin, add more support here
1324        ui_warning "WARNING: addgroup is not implemented on ${os.platform}."
1325        ui_warning "The requested group was not created."
1326    }
1327}
Note: See TracBrowser for help on using the repository browser.