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

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

Options should never be declared outside of a target

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