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

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

Fix "== 0" failure bug

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