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

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

Standardized return values for targets
Added msgcat calls to allow for target localization
Updated copyright date

  • 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            set result [$obj run]
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 {[portexec_int $portname install] == 0} {
1080                portexec_int $portname clean
1081    }
1082}
1083
1084# builds the specified port (looked up in the index) to the specified target
1085# doesn't yet support options or variants...
1086# newworkpath defines the port's workpath - useful for when one port relies
1087# on the source, etc, of another
1088proc portexec_int {portname target {newworkpath ""}} {
1089    ui_debug "Executing $target ($portname)"
1090    set variations [list]
1091    if {$newworkpath == ""} {
1092        array set options [list]
1093    } else {
1094        set options(workpath) ${newworkpath}
1095    }
1096        # Escape regex special characters
1097        regsub -all "(\\(){1}|(\\)){1}|(\\{1}){1}|(\\+){1}|(\\{1}){1}|(\\{){1}|(\\}){1}|(\\^){1}|(\\$){1}|(\\.){1}|(\\\\){1}" $portname "\\\\&" search_string
1098
1099    set res [dportsearch ^$search_string\$]
1100    if {[llength $res] < 2} {
1101        ui_error "Dependency $portname not found"
1102        return -1
1103    }
1104
1105    array set portinfo [lindex $res 1]
1106    set porturl $portinfo(porturl)
1107    set worker [dportopen $porturl [array get options] $variations]
1108    if {[catch {dportexec $worker $target} result] || $result != 0} {
1109        ui_error "Execution $portname $target failed: $result"
1110        dportclose $worker
1111        return -1
1112    }
1113    dportclose $worker
1114   
1115    return 0
1116}
1117
1118proc portfile_test {this} {
1119    set receipt [registry_exists [$this get name]]
1120    if {$receipt != ""} {
1121        ui_debug "Found Dependency: receipt: $receipt"
1122        return 1
1123    } else {
1124        return 0
1125    }
1126}
1127
1128proc portfile_search_path {depregex search_path} {
1129    set found 0
1130    foreach path $search_path {
1131        if {![file isdirectory $path]} {
1132            continue
1133        }
1134        foreach filename [readdir $path] {
1135            if {[regexp $depregex $filename] == 1} {
1136                ui_debug "Found Dependency: path: $path filename: $filename regex: $depregex"
1137                set found 1
1138                break
1139            }
1140        }
1141    }
1142    return $found
1143}
1144
1145
1146
1147##### lib portfile depspec subclass #####
1148# Search registry, then library path for regex
1149global libportfile_vtbl
1150array set libportfile_vtbl [array get portfile_vtbl]
1151set libportfile_vtbl(test) libportfile_test
1152
1153proc libportfile_new {name match} {
1154    set obj [portfile_new $name]
1155   
1156    $obj set _vtbl libportfile_vtbl
1157    $obj set depregex $match
1158   
1159    return $obj
1160}
1161
1162# XXX - Architecture specific
1163# XXX - Rely on information from internal defines in cctools/dyld:
1164# define DEFAULT_FALLBACK_FRAMEWORK_PATH
1165# /Library/Frameworks:/Library/Frameworks:/Network/Library/Frameworks:/System/Library/Frameworks
1166# define DEFAULT_FALLBACK_LIBRARY_PATH /lib:/usr/local/lib:/lib:/usr/lib
1167# Environment variables DYLD_FRAMEWORK_PATH, DYLD_LIBRARY_PATH,
1168# DYLD_FALLBACK_FRAMEWORK_PATH, and DYLD_FALLBACK_LIBRARY_PATH take precedence
1169
1170proc libportfile_test {this} {
1171    global env prefix
1172   
1173    # Check the registry first
1174    set result [portfile_test $this]
1175    if {$result == 1} {
1176        return $result
1177    } else {
1178        # Not in the registry, check the library path.
1179        set depregex [$this get depregex]
1180       
1181        if {[info exists env(DYLD_FRAMEWORK_PATH)]} {
1182            lappend search_path $env(DYLD_FRAMEWORK_PATH)
1183        } else {
1184            lappend search_path /Library/Frameworks /Network/Library/Frameworks /System/Library/Frameworks
1185        }
1186        if {[info exists env(DYLD_FALLBACK_FRAMEWORK_PATH)]} {
1187            lappend search_path $env(DYLD_FALLBACK_FRAMEWORK_PATH)
1188        }
1189        if {[info exists env(DYLD_LIBRARY_PATH)]} {
1190            lappend search_path $env(DYLD_LIBRARY_PATH)
1191        } else {
1192            lappend search_path /lib /usr/local/lib /lib /usr/lib /op/local/lib /usr/X11R6/lib ${prefix}/lib
1193        }
1194        if {[info exists env(DYLD_FALLBACK_LIBRARY_PATH)]} {
1195            lappend search_path $env(DYLD_LIBRARY_PATH)
1196        }
1197        regsub {\.} $depregex {\.} depregex
1198        set depregex \^$depregex.*\\.dylib\$
1199       
1200        return [portfile_search_path $depregex $search_path]
1201    }
1202}
1203
1204##### bin portfile depspec subclass #####
1205# Search registry, then binary path for regex
1206global binportfile_vtbl
1207array set binportfile_vtbl [array get portfile_vtbl]
1208set binportfile_vtbl(test) binportfile_test
1209
1210proc binportfile_new {name match} {
1211    set obj [portfile_new $name]
1212   
1213    $obj set _vtbl binportfile_vtbl
1214    $obj set depregex $match
1215   
1216    return $obj
1217}
1218
1219proc binportfile_test {this} {
1220    global env prefix
1221   
1222    # Check the registry first
1223    set result [portfile_test $this]
1224    if {$result == 1} {
1225        return $result
1226    } else {
1227        # Not in the registry, check the binary path.
1228        set depregex [$this get depregex]
1229       
1230        set search_path [split $env(PATH) :]
1231       
1232        set depregex \^$depregex\$
1233       
1234        return [portfile_search_path $depregex $search_path]
1235    }
1236}
1237
1238##### path portfile depspec subclass #####
1239# Search registry, then search specified absolute or
1240# ${prefix} relative path for regex
1241global pathportfile_vtbl
1242array set pathportfile_vtbl [array get portfile_vtbl]
1243set pathportfile_vtbl(test) pathportfile_test
1244
1245proc pathportfile_new {name match} {
1246    set obj [portfile_new $name]
1247   
1248    $obj set _vtbl pathportfile_vtbl
1249    $obj set depregex $match
1250    return $obj
1251}
1252
1253proc pathportfile_test {this} {
1254    global env prefix
1255   
1256    # Check the registry first
1257    set result [portfile_test $this]
1258    if {$result == 1} {
1259        return $result
1260    } else {
1261        # Not in the registry, check the path.
1262        # separate directory from regex
1263        set fullname [$this get depregex]
1264
1265        regexp {^(.*)/(.*?)$} "$fullname" match search_path depregex
1266
1267        if {[string index $search_path 0] != "/"} {
1268                # Prepend prefix if not an absolute path
1269                set search_path "${prefix}/${search_path}"
1270        }
1271               
1272        set depregex \^$depregex\$
1273       
1274        return [portfile_search_path $depregex $search_path]
1275    }
1276}
1277
1278proc adduser {name args} {
1279    global os.platform
1280    set passwd {\*}
1281    set uid [nextuid]
1282    set gid [existsgroup nogroup]
1283    set realname ${name}
1284    set home /dev/null
1285    set shell /dev/null
1286
1287    foreach arg $args {
1288        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
1289            regsub -all " " ${val} "\\ " val
1290            set $key $val
1291        }
1292    }
1293
1294    if {[existsuser ${name}] != 0 || [existsuser ${uid}] != 0} {
1295        return
1296    }
1297
1298    if {${os.platform} == "darwin"} {
1299        system "niutil -create . /users/${name}"
1300        system "niutil -createprop . /users/${name} name ${name}"
1301        system "niutil -createprop . /users/${name} passwd ${passwd}"
1302        system "niutil -createprop . /users/${name} uid ${uid}"
1303        system "niutil -createprop . /users/${name} gid ${gid}"
1304        system "niutil -createprop . /users/${name} realname ${realname}"
1305        system "niutil -createprop . /users/${name} home ${home}"
1306        system "niutil -createprop . /users/${name} shell ${shell}"
1307    } else {
1308        # XXX adduser is only available for darwin, add more support here
1309        ui_warn "WARNING: adduser is not implemented on ${os.platform}."
1310        ui_warn "The requested user was not created."
1311    }
1312}
1313
1314proc addgroup {name args} {
1315    global os.platform
1316    set gid [nextgid]
1317    set passwd {\*}
1318    set users ""
1319
1320    foreach arg $args {
1321        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
1322            regsub -all " " ${val} "\\ " val
1323            set $key $val
1324        }
1325    }
1326
1327    if {[existsgroup ${name}] != 0 || [existsgroup ${gid}] != 0} {
1328        return
1329    }
1330
1331    if {${os.platform} == "darwin"} {
1332        system "niutil -create . /groups/${name}"
1333        system "niutil -createprop . /groups/${name} name ${name}"
1334        system "niutil -createprop . /groups/${name} gid ${gid}"
1335        system "niutil -createprop . /groups/${name} passwd ${passwd}"
1336        system "niutil -createprop . /groups/${name} users ${users}"
1337    } else {
1338        # XXX addgroup is only available for darwin, add more support here
1339        ui_warn "WARNING: addgroup is not implemented on ${os.platform}."
1340        ui_warn "The requested group was not created."
1341    }
1342}
1343
1344proc x11prefix {args} {
1345    prefix /usr/X11R6
1346}
Note: See TracBrowser for help on using the repository browser.