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

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

Added variants.default to specify default variants. These do not override any
variants set by the client (command line).
Syntax:
variants.default +x11

  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 30.4 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    $obj set code $code
238    lappend all_variants $obj
239   
240    # Export provided variant to PortInfo
241    lappend PortInfo(variants) $provides
242}
243
244# variant_isset name
245# Returns 1 if variant name selected, otherwise 0
246proc variant_isset {name} {
247    global variations
248   
249    if {[info exists variations($name)] && $variations($name) == "+"} {
250        return 1
251    }
252    return 0
253}
254
255# variant_set name
256# Sets variant to run for current portfile
257proc variant_set {name} {
258    global variations
259   
260    set variations($name) +
261}
262
263# variant_unset name
264# Clear variant for current portfile
265proc variant_unset {name} {
266    global variations
267
268    set variations($name) -
269}
270
271########### Misc Utility Functions ###########
272
273# tbool (testbool)
274# If the variable exists in the calling procedure's namespace
275# and is set to "yes", return 1. Otherwise, return 0
276proc tbool {key} {
277    upvar $key $key
278    if {[info exists $key]} {
279        if {[string equal -nocase [set $key] "yes"]} {
280            return 1
281        }
282    }
283    return 0
284}
285
286# ldelete
287# Deletes a value from the supplied list
288proc ldelete {list value} {
289    upvar $list uplist
290    set ix [lsearch -exact $uplist $value]
291    if {$ix >= 0} {
292        set uplist [lreplace $uplist $ix $ix]
293    }
294}
295
296# reinplace
297# Provides "sed in place" functionality
298proc reinplace {oddpattern file}  {
299    set backpattern [strsed $oddpattern {g/\//\\\\\//}]
300    set pattern [strsed $backpattern {g/\|/\//}]
301
302    if {[catch {set input [open "$file" RDWR]} error]} {
303        ui_error "reinplace: $error"
304        return -code error "reinplace failed"
305    }
306
307    if {[catch {set result [mkstemp "/tmp/[file tail $file].sed.XXXXXXXX"]} error]} {
308        ui_error "reinplace: $error"
309        close $input
310        return -code error "reinplace failed"
311    }
312
313    set output [lindex $result 0]
314    set tmpfile [lindex $result 1]
315
316    if {[catch {exec sed $pattern <@$input >@$output} error]} {
317        ui_error "reinplace: $error"
318        close $output
319        close $input
320        file delete "$tmpfile"
321        return -code error "reinplace failed"
322    }
323
324    seek $output 0
325    seek $input 0
326
327    # copy from strsed output back into the input
328    if {[catch {fcopy $output $input} error]} {
329        ui_error "reinplace: $error"
330        close $output
331        close $input
332        file delete "$tmpfile"
333        return -code error "reinplace failed"
334    }
335       
336    set eof [file size "$tmpfile"]
337    ftruncate $input $eof 
338
339    close $output
340    close $input
341    file delete "$tmpfile"
342    return
343}
344
345# filefindbypath
346# Provides searching of the standard path for included files
347proc filefindbypath {fname} {
348    global distpath filedir workdir worksrcdir portpath
349
350    if [file readable $fname] {
351        return $fname
352    } elseif [file readable $portpath/$fname] {
353        return $portpath/$fname
354    } elseif [file readable $portpath/$filedir/$fname] {
355        return $portpath/$filedir/$fname
356    } elseif [file readable $distpath/$fname] {
357        return $distpath/$fname
358    } elseif [file readable $portpath/$workdir/$worksrcdir/$fname] {
359        return $portpath/$workdir/$worksrcdir/$fname
360    } elseif [file readable [file join /etc $fname]] {
361        return [file join /etc $fname]
362    }
363    return ""
364}
365
366# include
367# Source a file, looking for it along a standard search path.
368proc include {fname} {
369    set tgt [filefindbypath $fname]
370    if [string length $tgt] {
371        uplevel "source $tgt"
372    } else {
373        return -code error "Unable to find include file $fname"
374    }
375}
376
377# makeuserproc
378# This procedure re-writes the user-defined custom target to include
379# all the globals in its scope.  This is undeniably ugly, but I haven't
380# thought of any other way to do this.
381proc makeuserproc {name body} {
382    regsub -- "^\{(.*?)" $body "\{ \n eval \"global \[info globals\]\" \n \\1" body
383    eval "proc $name {} $body"
384}
385
386########### Internal Dependancy Manipulation Procedures ###########
387
388# returns a depspec by name
389proc dlist_get_by_name {dlist name} {
390    set result ""
391    foreach d $dlist {
392        if {[$d get name] == $name} {
393            set result $d
394            break
395        }
396    }
397    return $result
398}
399
400# returns a list of depspecs that contain the given name in the given key
401proc depspec_get_matches {dlist key value} {
402    set result [list]
403    foreach d $dlist {
404        foreach val [$d get $key] {
405            if {$val == $value} {
406                lappend result $d
407            }
408        }
409    }
410    return $result
411}
412
413# Count the unmet dependencies in the dlist based on the statusdict
414proc dlist_count_unmet {dlist statusdict names} {
415    upvar $statusdict upstatusdict
416    set unmet 0
417    foreach name $names {
418        # Service was provided, check next.
419        if {[info exists upstatusdict($name)] && $upstatusdict($name) == 1} {
420            continue
421        } else {
422            incr unmet
423        }
424    }
425    return $unmet
426}
427
428# Returns true if any of the dependencies are pending in the dlist
429proc dlist_has_pending {dlist uses} {
430    foreach name $uses {
431        if {[llength [depspec_get_matches $dlist provides $name]] > 0} {
432            return 1
433        }
434    }
435    return 0
436}
437
438# Get the name of the next eligible item from the dependency list
439proc generic_get_next {dlist statusdict} {
440    set nextitem ""
441    # arbitrary large number ~ INT_MAX
442    set minfailed 2000000000
443    upvar $statusdict upstatusdict
444   
445    foreach obj $dlist {               
446        # skip if unsatisfied hard dependencies
447        if {[dlist_count_unmet $dlist upstatusdict [$obj get requires]]} { continue }
448       
449        # favor item with fewest unment soft dependencies
450        set unmet [dlist_count_unmet $dlist upstatusdict [$obj get uses]]
451       
452        # delay items with unmet soft dependencies that can be filled
453        if {$unmet > 0 && [dlist_has_pending $dlist [$obj get uses]]} { continue }
454       
455        if {$unmet >= $minfailed} {
456            # not better than our last pick
457            continue
458        } else {
459            # better than our last pick
460            set minfailed $unmet
461            set nextitem $obj
462        }
463    }
464    return $nextitem
465}
466
467
468# Evaluate the list of depspecs, running each as it becomes eligible.
469# dlist is a collection of depspec objects to be run
470# get_next_proc is used to determine the best item to run
471proc dlist_evaluate {dlist get_next_proc} {
472    global portname
473       
474    # status - keys will be node names, values will be {-1, 0, 1}.
475    array set statusdict [list]
476       
477    # XXX: Do we want to evaluate this dynamically instead of statically?
478    foreach obj $dlist {
479        if {[$obj test] == 1} {
480            foreach name [$obj get provides] {
481                set statusdict($name) 1
482            }
483            ldelete dlist $obj
484        }
485    }
486   
487    # loop for as long as there are nodes in the dlist.
488    while (1) {
489        set obj [$get_next_proc $dlist statusdict]
490       
491        if {$obj == ""} { 
492            break
493        } else {
494            set result [$obj run]
495            # depspec->run returns an error code, so 0 == success.
496            # translate this to the statusdict notation where 1 == success.
497            foreach name [$obj get provides] {
498                set statusdict($name) [expr $result == 0]
499            }
500           
501            # Delete the item from the waiting list.
502            ldelete dlist $obj
503        }
504    }
505   
506    if {[llength $dlist] > 0} {
507        # somebody broke!
508        ui_info "Warning: the following items did not execute (for $portname): "
509        foreach obj $dlist {
510            ui_info "[$obj get name] " -nonewline
511        }
512        ui_info ""
513        return 1
514    }
515    return 0
516}
517
518proc target_run {this} {
519    global target_state_fd portname
520    set result 0
521    set procedure [$this get procedure]
522    if {$procedure != ""} {
523        set name [$this get name]
524       
525        if {[$this has init]} {
526            set result [catch {[$this get init] $name} errstr]
527        }
528       
529        if {[check_statefile $name $target_state_fd]} {
530            set result 0
531            ui_debug "Skipping completed $name ($portname)"
532        } else {
533            # Execute pre-run procedure
534            if {[$this has prerun]} {
535                set result [catch {[$this get prerun] $name} errstr]
536            }
537           
538            if {$result == 0} {
539                foreach pre [$this get pre] {
540                    ui_debug "Executing $pre"
541                    set result [catch {$pre $name} errstr]
542                    if {$result != 0} { break }
543                }
544            }
545           
546            if {$result == 0} {
547                ui_debug "Executing $name ($portname)"
548                set result [catch {$procedure $name} errstr]
549            }
550           
551            if {$result == 0} {
552                foreach post [$this get post] {
553                    ui_debug "Executing $post"
554                    set result [catch {$post $name} errstr]
555                    if {$result != 0} { break }
556                }
557            }
558            # Execute post-run procedure
559            if {[$this has postrun] && $result == 0} {
560                set postrun [$this get postrun]
561                ui_debug "Executing $postrun"
562                set result [catch {$postrun $name} errstr]
563            }
564        }
565        if {$result == 0} {
566            if {[$this get runtype] != "always"} {
567                write_statefile $name $target_state_fd
568            }
569        } else {
570            ui_error "Target error: $name returned: $errstr"
571            set result 1
572        }
573       
574    } else {
575        ui_info "Warning: $name does not have a registered procedure"
576        set result 1
577    }
578   
579    return $result
580}
581
582proc eval_targets {target} {
583    global targets target_state_fd
584    set dlist $targets
585   
586    # Select the subset of targets under $target
587    if {$target != ""} {
588        # XXX munge target. install really means registry, then install
589        # If more than one target ever needs this, make this a generic interface
590        if {$target == "install"} {
591            set target registry
592        }
593        set matches [depspec_get_matches $dlist provides $target]
594        if {[llength $matches] > 0} {
595            set dlist [dlist_append_dependents $dlist [lindex $matches 0] [list]]
596            # Special-case 'all'
597        } elseif {$target != "all"} {
598            ui_info "unknown target: $target"
599            return 1
600        }
601    }
602   
603    # Restore the state from a previous run.
604    set target_state_fd [open_statefile]
605   
606    set ret [dlist_evaluate $dlist generic_get_next]
607   
608    close $target_state_fd
609    return $ret
610}
611
612# returns the names of dependents of <name> from the <itemlist>
613proc dlist_append_dependents {dlist obj result} {
614   
615    # Append the item to the list, avoiding duplicates
616    if {[lsearch $result $obj] == -1} {
617        lappend result $obj
618    }
619   
620    # Recursively append any hard dependencies
621    foreach dep [$obj get requires] {
622        foreach provider [depspec_get_matches $dlist provides $dep] {
623            set result [dlist_append_dependents $dlist $provider $result]
624        }
625    }
626    # XXX: add soft-dependencies?
627    return $result
628}
629
630# open_statefile
631# open file to store name of completed targets
632proc open_statefile {args} {
633    global portpath workdir
634   
635    if ![file isdirectory $portpath/$workdir] {
636        file mkdir $portpath/$workdir
637    }
638    # flock Portfile
639    set statefile [file join $portpath $workdir .darwinports.state]
640    if {[file exists $statefile] && ![file writable $statefile]} {
641        return -code error "$statefile is not writable - check permission on port directory"
642    }
643    set fd [open $statefile a+]
644    if [catch {flock $fd -exclusive -noblock} result] {
645        if {"$result" == "EAGAIN"} {
646            ui_puts "Waiting for lock on $statefile"
647        } elseif {"$result" == "EOPNOTSUPP"} {
648            # Locking not supported, just return
649            return $fd
650        } else {
651            return -code error "$result obtaining lock on $statefile"
652        }
653    }
654    flock $fd -exclusive
655    return $fd
656}
657
658# check_statefile
659# Check completed state of target $name
660proc check_statefile {name fd} {
661    global portpath workdir
662   
663    seek $fd 0
664    while {[gets $fd line] >= 0} {
665        if {[string equal $line $name]} {
666            return 1
667        }
668    }
669    return 0
670}
671
672# write_statefile
673# Set target $name completed in the state file
674proc write_statefile {name fd} {
675    if {[check_statefile $name $fd]} {
676        return 0
677    }
678    seek $fd 0 end
679    puts $fd $name
680    flush $fd
681}
682
683# Traverse the ports collection hierarchy and call procedure func for
684# each directory containing a Portfile
685proc port_traverse {func {dir .}} {
686    set pwd [pwd]
687    if [catch {cd $dir} err] {
688        ui_error $err
689        return
690    }
691    foreach name [readdir .] {
692        if {[string match $name .] || [string match $name ..]} {
693            continue
694        }
695        if [file isdirectory $name] {
696            port_traverse $func $name
697        } else {
698            if [string match $name Portfile] {
699                catch {eval $func {[file join $pwd $dir]}}
700            }
701        }
702    }
703    cd $pwd
704}
705
706
707########### Port Variants ###########
708
709# Each variant which provides a subset of the requested variations
710# will be chosen.  Returns a list of the selected variants.
711proc choose_variants {dlist variations} {
712    upvar $variations upvariations
713   
714    set selected [list]
715   
716    foreach obj $dlist {
717        # Enumerate through the provides, tallying the pros and cons.
718        set pros 0
719        set cons 0
720        set ignored 0
721        foreach flavor [$obj get provides] {
722            if {[info exists upvariations($flavor)]} {
723                if {$upvariations($flavor) == "+"} {
724                    incr pros
725                } elseif {$upvariations($flavor) == "-"} {
726                    incr cons
727                }
728            } else {
729                incr ignored
730            }
731        }
732       
733        if {$cons > 0} { continue }
734       
735        if {$pros > 0 && $ignored == 0} {
736            lappend selected $obj
737        }
738    }
739    return $selected
740}
741
742proc variant_run {this} {
743    set name [$this get name]
744    ui_debug "Executing $name provides [$this get provides]"
745    makeuserproc ${name}-code "[$this get code]"
746    if ([catch ${name}-code result]) {
747        ui_error "Error executing $name: $result"
748        return 1
749    }
750    return 0
751}
752
753proc eval_variants {variations} {
754    global all_variants
755    set dlist $all_variants
756    upvar $variations upvariations
757    set chosen [choose_variants $dlist upvariations]
758   
759    # now that we've selected variants, change all provides [a b c] to [a-b-c]
760    # this will eliminate ambiguity between item a, b, and a-b while fulfilling requirments.
761    #foreach obj $dlist {
762    #    $obj set provides [list [join [$obj get provides] -]]
763    #}
764   
765    set newlist [list]
766    foreach variant $chosen {
767        set newlist [dlist_append_dependents $dlist $variant $newlist]
768    }
769   
770    dlist_evaluate $newlist generic_get_next
771}
772
773##### DEPSPEC #####
774
775# Object-Oriented Depspecs
776#
777# Each depspec will have its data stored in an array
778# (indexed by field name) and its procedures will be
779# called via the dispatch procedure that is returned
780# from depspec_new.
781#
782# sample usage:
783# set obj [depspec_new]
784# $obj set name "hello"
785#
786
787# Depspec
788#       str name
789#       str provides[]
790#       str requires[]
791#       str uses[]
792
793global depspec_uniqid
794set depspec_uniqid 0
795
796# Depspec class definition.
797global depspec_vtbl
798set depspec_vtbl(test) depspec_test
799set depspec_vtbl(run) depspec_run
800set depspec_vtbl(get) depspec_get
801set depspec_vtbl(set) depspec_set
802set depspec_vtbl(has) depspec_has
803set depspec_vtbl(append) depspec_append
804
805# constructor for abstract depspec class
806proc depspec_new {name} {
807    global depspec_uniqid
808    set id [incr depspec_uniqid]
809   
810    # declare the array of data
811    set data dpspc_data_${id}
812    set disp dpspc_disp_${id}
813   
814    global $data 
815    set ${data}(name) $name
816    set ${data}(_vtbl) depspec_vtbl
817   
818    eval "proc $disp {method args} { \n \
819                        global $data \n \
820                        eval return \\\[depspec_dispatch $disp $data \$method \$args\\\] \n \
821                }"
822   
823    return $disp
824}
825
826proc depspec_get {this prop} {
827        set data [$this _data]
828        global $data
829        if {[eval info exists ${data}($prop)]} {
830                eval return $${data}($prop)
831        } else {
832                return ""
833        }
834}
835
836proc depspec_set {this prop args} {
837        set data [$this _data]
838        global $data
839        eval "set ${data}($prop) \"$args\""
840}
841
842proc depspec_has {this prop} {
843        set data [$this _data]
844        global $data
845        eval return \[info exists ${data}($prop)\]
846}
847
848proc depspec_append {this prop args} {
849        set data [$this _data]
850        global $data
851        set vals [join $args " "]
852        eval lappend ${data}($prop) $vals
853}
854
855# is the only proc to get direct access to the object's data
856# so the _data accessor has to be defined here.  all other
857# methods are looked up in the virtual function table,
858# and are called with {$this $args}.
859proc depspec_dispatch {this data method args} {
860    global $data
861        if {$method == "_data"} { return $data }
862        eval set vtbl $${data}(_vtbl)
863        global $vtbl
864        if {[info exists ${vtbl}($method)]} {
865                eval set function $${vtbl}($method)
866                eval "return \[$function $this $args\]"
867        } else {
868                ui_error "unknown method: $method"
869        }
870    return ""
871}
872
873proc depspec_test {this} {
874    return 0
875}
876
877proc depspec_run {this} {
878    return 0
879}
880
881##### target depspec subclass #####
882
883# Target class definition.
884global target_vtbl
885array set target_vtbl [array get depspec_vtbl]
886set target_vtbl(run) target_run
887set target_vtbl(provides) target_provides
888set target_vtbl(requires) target_requires
889set target_vtbl(uses) target_uses
890set target_vtbl(deplist) target_deplist
891set target_vtbl(prerun) target_prerun
892set target_vtbl(postrun) target_postrun
893
894# constructor for target depspec class
895proc target_new {name procedure} {
896        global targets
897        set obj [depspec_new $name]
898   
899    $obj set _vtbl target_vtbl
900        $obj set procedure $procedure
901   
902        lappend targets $obj
903       
904    return $obj
905}
906
907proc target_provides {this args} {
908        global targets
909        # Register the pre-/post- hooks for use in Portfile.
910        # Portfile syntax: pre-fetch { puts "hello world" }
911        # User-code exceptions are caught and returned as a result of the target.
912        # Thus if the user code breaks, dependent targets will not execute.
913        foreach target $args {
914                if {[info commands $target] != ""} {
915                        ui_error "$name attempted to register provide \'$target\' which is a pre-existing procedure. Ignoring register."
916                        continue;
917                }
918                set origproc [$this get procedure]
919                set ident [$this get name]
920                eval "proc $target {args} \{ \n\
921                        $this set procedure proc-${ident}-${target}
922                        eval \"proc proc-${ident}-${target} \{name\} \{ \n\
923                                if \{\\\[catch userproc-${ident}-${target} result\\\]\} \{ \n\
924                                        ui_info \\\$result \n\
925                                        return 1 \n\
926                                \} else \{ \n\
927                                        return 0 \n\
928                                \} \n\
929                        \}\" \n\
930                        eval \"proc do-$target \{\} \{ $origproc $target\}\" \n\
931                        makeuserproc userproc-${ident}-${target} \$args \n\
932                \}"
933                eval "proc pre-$target {args} \{ \n\
934                        $this append pre proc-pre-${ident}-${target}
935                        eval \"proc proc-pre-${ident}-${target} \{name\} \{ \n\
936                                if \{\\\[catch userproc-pre-${ident}-${target} result\\\]\} \{ \n\
937                                        ui_info \\\$result \n\
938                                        return 1 \n\
939                                \} else \{ \n\
940                                        return 0 \n\
941                                \} \n\
942                        \}\" \n\
943                        makeuserproc userproc-pre-${ident}-${target} \$args \n\
944                \}"
945                eval "proc post-$target {args} \{ \n\
946                        $this append post proc-post-${ident}-${target}
947                        eval \"proc proc-post-${ident}-${target} \{name\} \{ \n\
948                                if \{\\\[catch userproc-post-${ident}-${target} result\\\]\} \{ \n\
949                                        ui_info \\\$result \n\
950                                        return 1 \n\
951                                \} else \{ \n\
952                                        return 0 \n\
953                                \} \n\
954                        \}\" \n\
955                        makeuserproc userproc-post-${ident}-${target} \$args \n\
956                \}"
957        }
958        eval "depspec_append $this provides $args"
959}
960
961proc target_requires {this args} {
962        eval "depspec_append $this requires $args"
963}
964
965proc target_uses {this args} {
966        eval "depspec_append $this uses $args"
967}
968
969proc target_deplist {this args} {
970        eval "depspec_append $this deplist $args"
971}
972
973proc target_prerun {this args} {
974        eval "depspec_append $this prerun $args"
975}
976
977proc target_postrun {this args} {
978        eval "depspec_append $this postrun $args"
979}
980
981##### variant depspec subclass #####
982
983# Variant class definition.
984global variant_vtbl
985array set variant_vtbl [array get depspec_vtbl]
986set variant_vtbl(run) variant_run
987
988# constructor for target depspec class
989proc variant_new {name} {
990    set obj [depspec_new $name]
991   
992    $obj set _vtbl variant_vtbl
993   
994    return $obj
995}
996
997options variants.default
998option_proc variants.default handle_variants.default
999proc handle_variants.default {option action args} {
1000        global variations
1001    switch -regex $action {
1002                set|append {
1003                        foreach v $args {
1004                                if {[regexp {([-+])([-A-Za-z0-9_]+)} $v whole val variant]} {
1005                                        if {![info exists variations($variant)]} {
1006                                                set variations($variant) $val
1007                                        }
1008                                }
1009                        }
1010                }
1011                delete {
1012                        # xxx
1013                }
1014    }
1015}
1016
1017##### portfile depspec subclass #####
1018global portfile_vtbl
1019array set portfile_vtbl [array get depspec_vtbl]
1020set portfile_vtbl(run) portfile_run
1021set portfile_vtbl(test) portfile_test
1022
1023proc portfile_new {name} {
1024    set obj [depspec_new $name]
1025   
1026    $obj set _vtbl portfile_vtbl
1027   
1028    return $obj
1029}
1030
1031# build the specified portfile
1032proc portfile_run {this} {
1033    set portname [$this get name]
1034   
1035    ui_debug "Building $portname"
1036    array set options [list]
1037    array set variations [list]
1038    array set portinfo [dportmatch ^$portname\$]
1039    if {[array size portinfo] == 0} {
1040        ui_error "Dependency $portname not found"
1041        return -1
1042    }
1043    set porturl $portinfo(porturl)
1044   
1045    set worker [dportopen $porturl options variations]
1046    if {[catch {dportexec $worker clean} result] || $result != 0} {
1047        ui_error "Clean of $portname before build failed: $result"
1048        dportclose $worker
1049        return -1
1050    }
1051    if {[catch {dportexec $worker install} result] || $result != 0} {
1052        ui_error "Build of $portname failed: $result"
1053        dportclose $worker
1054        return -1
1055    }
1056    if {[catch {dportexec $worker clean} result] || $result != 0} {
1057        ui_error "Clean of $portname after build failed: $result"
1058    }
1059    dportclose $worker
1060   
1061    return 0
1062}
1063
1064proc portfile_test {this} {
1065    set receipt [registry_exists [$this get name]]
1066    if {$receipt != ""} {
1067        ui_debug "Found Dependency: receipt: $receipt"
1068        return 1
1069    } else {
1070        return 0
1071    }
1072}
1073
1074proc portfile_search_path {depregex search_path} {
1075    set found 0
1076    foreach path $search_path {
1077        if {![file isdirectory $path]} {
1078            continue
1079        }
1080        foreach filename [readdir $path] {
1081            if {[regexp $depregex $filename] == 1} {
1082                ui_debug "Found Dependency: path: $path filename: $filename regex: $depregex"
1083                set found 1
1084                break
1085            }
1086        }
1087    }
1088    return $found
1089}
1090
1091
1092
1093##### lib portfile depspec subclass #####
1094global libportfile_vtbl
1095array set libportfile_vtbl [array get portfile_vtbl]
1096set libportfile_vtbl(test) libportfile_test
1097
1098proc libportfile_new {name match} {
1099    set obj [portfile_new $name]
1100   
1101    $obj set _vtbl libportfile_vtbl
1102    $obj set depregex $match
1103   
1104    return $obj
1105}
1106
1107# XXX - Architecture specific
1108# XXX - Rely on information from internal defines in cctools/dyld:
1109# define DEFAULT_FALLBACK_FRAMEWORK_PATH
1110# /Library/Frameworks:/Library/Frameworks:/Network/Library/Frameworks:/System/Library/Frameworks
1111# define DEFAULT_FALLBACK_LIBRARY_PATH /lib:/usr/local/lib:/lib:/usr/lib
1112# Environment variables DYLD_FRAMEWORK_PATH, DYLD_LIBRARY_PATH,
1113# DYLD_FALLBACK_FRAMEWORK_PATH, and DYLD_FALLBACK_LIBRARY_PATH take precedence
1114
1115proc libportfile_test {this} {
1116    global env prefix
1117   
1118    # Check the registry first
1119    set result [portfile_test $this]
1120    if {$result == 1} {
1121        return $result
1122    } else {
1123        # Not in the registry, check the library path.
1124        set depregex [$this get depregex]
1125       
1126        if {[info exists env(DYLD_FRAMEWORK_PATH)]} {
1127            lappend search_path $env(DYLD_FRAMEWORK_PATH)
1128        } else {
1129            lappend search_path /Library/Frameworks /Network/Library/Frameworks /System/Library/Frameworks
1130        }
1131        if {[info exists env(DYLD_FALLBACK_FRAMEWORK_PATH)]} {
1132            lappend search_path $env(DYLD_FALLBACK_FRAMEWORK_PATH)
1133        }
1134        if {[info exists env(DYLD_LIBRARY_PATH)]} {
1135            lappend search_path $env(DYLD_LIBRARY_PATH)
1136        } else {
1137            lappend search_path /lib /usr/local/lib /lib /usr/lib /op/local/lib /usr/X11R6/lib ${prefix}/lib
1138        }
1139        if {[info exists env(DYLD_FALLBACK_LIBRARY_PATH)]} {
1140            lappend search_path $env(DYLD_LIBRARY_PATH)
1141        }
1142        regsub {\.} $depregex {\.} depregex
1143        set depregex \^$depregex.*\\.dylib\$
1144       
1145        return [portfile_search_path $depregex $search_path]
1146    }
1147}
1148
1149##### bin portfile depspec subclass #####
1150global binportfile_vtbl
1151array set binportfile_vtbl [array get portfile_vtbl]
1152set binportfile_vtbl(test) binportfile_test
1153
1154proc binportfile_new {name match} {
1155    set obj [portfile_new $name]
1156   
1157    $obj set _vtbl binportfile_vtbl
1158    $obj set depregex $match
1159   
1160    return $obj
1161}
1162
1163proc binportfile_test {this} {
1164    global env prefix
1165   
1166    # Check the registry first
1167    set result [portfile_test $this]
1168    if {$result == 1} {
1169        return $result
1170    } else {
1171        # Not in the registry, check the binary path.
1172        set depregex [$this get depregex]
1173       
1174        set search_path [split $env(PATH) :]
1175       
1176        set depregex \^$depregex\$
1177       
1178        return [portfile_search_path $depregex $search_path]
1179    }
1180}
Note: See TracBrowser for help on using the repository browser.