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

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

Remove 'register' proc.
Now targets have a handle to the target object directly. Alleviates need for
unique names, and simplifies pre-${target}/post-${target} implementation.
Will allow for future enhancement to options and variants.

  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 30.0 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 variants
36
37set targets [list]
38set target_uniqid 0
39
40set 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 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 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 foreach g \[info globals\] \{ \n global \$g \n \} \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 variants
755    set dlist $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
997
998
999##### portfile depspec subclass #####
1000global portfile_vtbl
1001array set portfile_vtbl [array get depspec_vtbl]
1002set portfile_vtbl(run) portfile_run
1003set portfile_vtbl(test) portfile_test
1004
1005proc portfile_new {name} {
1006    set obj [depspec_new $name]
1007   
1008    $obj set _vtbl portfile_vtbl
1009   
1010    return $obj
1011}
1012
1013# build the specified portfile
1014proc portfile_run {this} {
1015    set portname [$this get name]
1016   
1017    ui_debug "Building $portname"
1018    array set options [list]
1019    array set variations [list]
1020    array set portinfo [dportmatch ^$portname\$]
1021    if {[array size portinfo] == 0} {
1022        ui_error "Dependency $portname not found"
1023        return -1
1024    }
1025    set porturl $portinfo(porturl)
1026   
1027    set worker [dportopen $porturl options variations]
1028    if {[catch {dportexec $worker clean} result] || $result != 0} {
1029        ui_error "Clean of $portname before build failed: $result"
1030        dportclose $worker
1031        return -1
1032    }
1033    if {[catch {dportexec $worker install} result] || $result != 0} {
1034        ui_error "Build of $portname failed: $result"
1035        dportclose $worker
1036        return -1
1037    }
1038    if {[catch {dportexec $worker clean} result] || $result != 0} {
1039        ui_error "Clean of $portname after build failed: $result"
1040    }
1041    dportclose $worker
1042   
1043    return 0
1044}
1045
1046proc portfile_test {this} {
1047    set receipt [registry_exists [$this get name]]
1048    if {$receipt != ""} {
1049        ui_debug "Found Dependency: receipt: $receipt"
1050        return 1
1051    } else {
1052        return 0
1053    }
1054}
1055
1056proc portfile_search_path {depregex search_path} {
1057    set found 0
1058    foreach path $search_path {
1059        if {![file isdirectory $path]} {
1060            continue
1061        }
1062        foreach filename [readdir $path] {
1063            if {[regexp $depregex $filename] == 1} {
1064                ui_debug "Found Dependency: path: $path filename: $filename regex: $depregex"
1065                set found 1
1066                break
1067            }
1068        }
1069    }
1070    return $found
1071}
1072
1073
1074
1075##### lib portfile depspec subclass #####
1076global libportfile_vtbl
1077array set libportfile_vtbl [array get portfile_vtbl]
1078set libportfile_vtbl(test) libportfile_test
1079
1080proc libportfile_new {name match} {
1081    set obj [portfile_new $name]
1082   
1083    $obj set _vtbl libportfile_vtbl
1084    $obj set depregex $match
1085   
1086    return $obj
1087}
1088
1089# XXX - Architecture specific
1090# XXX - Rely on information from internal defines in cctools/dyld:
1091# define DEFAULT_FALLBACK_FRAMEWORK_PATH
1092# /Library/Frameworks:/Library/Frameworks:/Network/Library/Frameworks:/System/Library/Frameworks
1093# define DEFAULT_FALLBACK_LIBRARY_PATH /lib:/usr/local/lib:/lib:/usr/lib
1094# Environment variables DYLD_FRAMEWORK_PATH, DYLD_LIBRARY_PATH,
1095# DYLD_FALLBACK_FRAMEWORK_PATH, and DYLD_FALLBACK_LIBRARY_PATH take precedence
1096
1097proc libportfile_test {this} {
1098    global env prefix
1099   
1100    # Check the registry first
1101    set result [portfile_test $this]
1102    if {$result == 1} {
1103        return $result
1104    } else {
1105        # Not in the registry, check the library path.
1106        set depregex [$this get depregex]
1107       
1108        if {[info exists env(DYLD_FRAMEWORK_PATH)]} {
1109            lappend search_path $env(DYLD_FRAMEWORK_PATH)
1110        } else {
1111            lappend search_path /Library/Frameworks /Network/Library/Frameworks /System/Library/Frameworks
1112        }
1113        if {[info exists env(DYLD_FALLBACK_FRAMEWORK_PATH)]} {
1114            lappend search_path $env(DYLD_FALLBACK_FRAMEWORK_PATH)
1115        }
1116        if {[info exists env(DYLD_LIBRARY_PATH)]} {
1117            lappend search_path $env(DYLD_LIBRARY_PATH)
1118        } else {
1119            lappend search_path /lib /usr/local/lib /lib /usr/lib /op/local/lib /usr/X11R6/lib ${prefix}/lib
1120        }
1121        if {[info exists env(DYLD_FALLBACK_LIBRARY_PATH)]} {
1122            lappend search_path $env(DYLD_LIBRARY_PATH)
1123        }
1124        regsub {\.} $depregex {\.} depregex
1125        set depregex \^$depregex.*\\.dylib\$
1126       
1127        return [portfile_search_path $depregex $search_path]
1128    }
1129}
1130
1131##### bin portfile depspec subclass #####
1132global binportfile_vtbl
1133array set binportfile_vtbl [array get portfile_vtbl]
1134set binportfile_vtbl(test) binportfile_test
1135
1136proc binportfile_new {name match} {
1137    set obj [portfile_new $name]
1138   
1139    $obj set _vtbl binportfile_vtbl
1140    $obj set depregex $match
1141   
1142    return $obj
1143}
1144
1145proc binportfile_test {this} {
1146    global env prefix
1147   
1148    # Check the registry first
1149    set result [portfile_test $this]
1150    if {$result == 1} {
1151        return $result
1152    } else {
1153        # Not in the registry, check the binary path.
1154        set depregex [$this get depregex]
1155       
1156        set search_path [split $env(PATH) :]
1157       
1158        set depregex \^$depregex\$
1159       
1160        return [portfile_search_path $depregex $search_path]
1161    }
1162}
Note: See TracBrowser for help on using the repository browser.