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

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

Added path: class of depspec which is satisfied by a regex at an arbitrary
absolute or ${prefix}-relative path.

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