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

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

Remove a variable if we delete the last item in the list

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