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

Last change on this file since 13377 was 13377, checked in by pguyot, 12 years ago

Fix dependency bug.

  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 37.2 KB
Line 
1# et:ts=4
2# portutil.tcl
3#
4# Copyright (c) 2004 Robert Shaw <rshaw@opendarwin.org>
5# Copyright (c) 2002 Apple Computer, Inc.
6# All rights reserved.
7#
8# Redistribution and use in source and binary forms, with or without
9# modification, are permitted provided that the following conditions
10# are met:
11# 1. Redistributions of source code must retain the above copyright
12#    notice, this list of conditions and the following disclaimer.
13# 2. Redistributions in binary form must reproduce the above copyright
14#    notice, this list of conditions and the following disclaimer in the
15#    documentation and/or other materials provided with the distribution.
16# 3. Neither the name of Apple Computer, Inc. nor the names of its contributors
17#    may be used to endorse or promote products derived from this software
18#    without specific prior written permission.
19#
20# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
21# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
22# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
23# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
24# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
25# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
26# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
27# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
28# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
29# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
30# POSSIBILITY OF SUCH DAMAGE.
31#
32
33package provide portutil 1.0
34package require Pextlib 1.0
35package require darwinports_dlist 1.0
36package require msgcat
37package require porttrace 1.0
38package require darwinports 1.0
39
40global targets target_uniqid all_variants
41
42set targets [list]
43set target_uniqid 0
44
45set all_variants [list]
46
47########### External High Level Procedures ###########
48
49
50# UI Instantiations
51foreach priority "debug info msg error warn" {
52    eval "proc ui_$priority {str} \{ \n\
53        set message(priority) $priority \n\
54        set message(data) \$str \n\
55        ui_event \[array get message\] \n\
56    \}"
57}
58
59
60namespace eval options {
61}
62
63# option
64# This is an accessor for Portfile options.  Targets may use
65# this in the same style as the standard Tcl "set" procedure.
66#       name  - the name of the option to read or write
67#       value - an optional value to assign to the option
68
69proc option {name args} {
70    # XXX: right now we just transparently use globals
71    # eventually this will need to bridge the options between
72    # the Portfile's interpreter and the target's interpreters.
73    global $name
74    if {[llength $args] > 0} {
75        ui_debug "setting option $name to $args"
76        set $name [lindex $args 0]
77    }
78    return [set $name]
79}
80
81# exists
82# This is an accessor for Portfile options.  Targets may use
83# this procedure to test for the existence of a Portfile option.
84#       name - the name of the option to test for existence
85
86proc exists {name} {
87    # XXX: right now we just transparently use globals
88    # eventually this will need to bridge the options between
89    # the Portfile's interpreter and the target's interpreters.
90    global $name
91    return [info exists $name]
92}
93
94# options
95# Exports options in an array as externally callable procedures
96# Thus, "options name date" would create procedures named "name"
97# and "date" that set global variables "name" and "date", respectively
98# When an option is modified in any way, options::$option is called,
99# if it exists
100# Arguments: <list of options>
101proc options {args} {
102    foreach option $args {
103        eval "proc $option {args} \{ \n\
104            global ${option} user_options option_procs \n\
105                \if \{!\[info exists user_options(${option})\]\} \{ \n\
106                     set ${option} \$args \n\
107                \} \n\
108        \}"
109       
110        eval "proc ${option}-delete {args} \{ \n\
111            global ${option} user_options option_procs \n\
112                \if \{!\[info exists user_options(${option})\]\ && \[info exists ${option}\]\} \{ \n\
113                    foreach val \$args \{ \n\
114                       set ${option} \[ldelete \$\{$option\} \$val\] \n\
115                    \} \n\
116                    if \{\[string length \$\{${option}\}\] == 0\} \{ \n\
117                        unset ${option} \n\
118                    \} \n\
119                \} \n\
120        \}"
121        eval "proc ${option}-append {args} \{ \n\
122            global ${option} user_options option_procs \n\
123                \if \{!\[info exists user_options(${option})\]\} \{ \n\
124                    if \{\[info exists ${option}\]\} \{ \n\
125                        set ${option} \[concat \$\{$option\} \$args\] \n\
126                    \} else \{ \n\
127                        set ${option} \$args \n\
128                    \} \n\
129                \} \n\
130        \}"
131    }
132}
133
134proc options_export {args} {
135    foreach option $args {
136        eval "proc options::export-${option} \{args\} \{ \n\
137            global ${option} PortInfo \n\
138            if \{\[info exists ${option}\]\} \{ \n\
139                set PortInfo(${option}) \$\{${option}\} \n\
140            \} else \{ \n\
141                unset PortInfo(${option}) \n\
142            \} \n\
143        \}"
144        option_proc ${option} options::export-${option}
145    }
146}
147
148# option_deprecate
149# Causes a warning to be printed when an option is set or accessed
150proc option_deprecate {option {newoption ""} } {
151    # If a new option is specified, default the option to {${newoption}}
152    # Display a warning
153    if {$newoption != ""} {
154        eval "proc warn_deprecated_$option \{option action args\} \{ \n\
155            global portname $option $newoption \n\
156            if \{\$action != \"read\"\} \{ \n\
157                $newoption \$$option \n\
158            \} else \{ \n\
159                ui_warn \"Port \$portname using deprecated option \\\"$option\\\".\" \n\
160                $option \[set $newoption\] \n\
161            \} \n\
162        \}"
163    } else {
164        eval "proc warn_deprecated_$option \{option action args\} \{ \n\
165            global portname $option $newoption \n\
166            ui_warn \"Port \$portname using deprecated option \\\"$option\\\".\" \n\
167        \}"
168    }
169    option_proc $option warn_deprecated_$option
170}
171
172proc option_proc {option args} {
173    global option_procs $option
174    eval "lappend option_procs($option) $args"
175    # Add a read trace to the variable, as the option procedures have no access to reads
176    trace variable $option rwu option_proc_trace
177}
178
179# option_proc_trace
180# trace handler for option reads. Calls option procedures with correct arguments.
181proc option_proc_trace {optionName index op} {
182    global option_procs
183    upvar $optionName optionValue
184    switch $op {
185        w {
186            foreach p $option_procs($optionName) {
187                eval "$p $optionName set ${optionValue}" 
188            }
189            return
190        }
191        r {
192            foreach p $option_procs($optionName) {
193                eval "$p $optionName read"
194            }
195            return
196        }
197        u {
198            foreach p $option_procs($optionName) {
199                eval "$p $optionName delete"
200                trace vdelete $optionName rwu $p
201            }
202            return
203        }
204    }
205}
206
207# commands
208# Accepts a list of arguments, of which several options are created
209# and used to form a standard set of command options.
210proc commands {args} {
211    foreach option $args {
212        options use_${option} ${option}.dir ${option}.pre_args ${option}.args ${option}.post_args ${option}.env ${option}.type ${option}.cmd
213    }
214}
215
216# command
217# Given a command name, command assembled a string
218# composed of the command options.
219proc command {command} {
220    global ${command}.dir ${command}.pre_args ${command}.args ${command}.post_args ${command}.env ${command}.type ${command}.cmd
221   
222    set cmdstring ""
223    if {[info exists ${command}.dir]} {
224        set cmdstring "cd \"[set ${command}.dir]\" &&"
225    }
226   
227    if {[info exists ${command}.env]} {
228        foreach string [set ${command}.env] {
229            set cmdstring "$cmdstring $string"
230        }
231    }
232   
233    if {[info exists ${command}.cmd]} {
234        foreach string [set ${command}.cmd] {
235            set cmdstring "$cmdstring $string"
236        }
237    } else {
238        set cmdstring "$cmdstring ${command}"
239    }
240    foreach var "${command}.pre_args ${command}.args ${command}.post_args" {
241        if {[info exists $var]} {
242            foreach string [set ${var}] {
243                set cmdstring "$cmdstring $string"
244            }
245        }
246    }
247    ui_debug "Assembled command: '$cmdstring'"
248    return $cmdstring
249}
250
251# default
252# Sets a variable to the supplied default if it does not exist,
253# and adds a variable trace. The variable traces allows for delayed
254# variable and command expansion in the variable's default value.
255proc default {option val} {
256    global $option option_defaults
257    if {[info exists option_defaults($option)]} {
258        ui_debug "Re-registering default for $option"
259        # remove the old trace
260        trace vdelete $option rwu default_check
261    } else {
262        # If option is already set and we did not set it
263        # do not reset the value
264        if {[info exists $option]} {
265            return
266        }
267    }
268    set option_defaults($option) $val
269    set $option $val
270    trace variable $option rwu default_check
271}
272
273# default_check
274# trace handler to provide delayed variable & command expansion
275# for default variable values
276proc default_check {optionName index op} {
277    global option_defaults $optionName
278    switch $op {
279        w {
280            unset option_defaults($optionName)
281            trace vdelete $optionName rwu default_check
282            return
283        }
284        r {
285            upvar $optionName option
286            uplevel #0 set $optionName $option_defaults($optionName)
287            return
288        }
289        u {
290            unset option_defaults($optionName)
291            trace vdelete $optionName rwu default_check
292            return
293        }
294    }
295}
296
297# variant <provides> [<provides> ...] [requires <requires> [<requires>]]
298# Portfile level procedure to provide support for declaring variants
299proc variant {args} {
300    global all_variants PortInfo
301    upvar $args upargs
302   
303    set len [llength $args]
304    set code [lindex $args end]
305    set args [lrange $args 0 [expr $len - 2]]
306   
307    set ditem [variant_new "temp-variant"]
308   
309    # mode indicates what the arg is interpreted as.
310    # possible mode keywords are: requires, conflicts, provides
311    # The default mode is provides.  Arguments are added to the
312    # most recently specified mode (left to right).
313    set mode "provides"
314    foreach arg $args {
315        switch -exact $arg {
316            provides { set mode "provides" }
317            requires { set mode "requires" }
318            conflicts { set mode "conflicts" }
319            default { ditem_append $ditem $mode $arg }         
320        }
321    }
322    ditem_key $ditem name "[join [ditem_key $ditem provides] -]"
323   
324    # make a user procedure named variant-blah-blah
325    # we will call this procedure during variant-run
326    makeuserproc "variant-[ditem_key $ditem name]" \{$code\}
327    lappend all_variants $ditem
328   
329    # Export provided variant to PortInfo
330    lappend PortInfo(variants) [ditem_key $ditem provides]
331}
332
333# variant_isset name
334# Returns 1 if variant name selected, otherwise 0
335proc variant_isset {name} {
336    global variations
337   
338    if {[info exists variations($name)] && $variations($name) == "+"} {
339        return 1
340    }
341    return 0
342}
343
344# variant_set name
345# Sets variant to run for current portfile
346proc variant_set {name} {
347    global variations
348   
349    set variations($name) +
350}
351
352# variant_unset name
353# Clear variant for current portfile
354proc variant_unset {name} {
355    global variations
356   
357    set variations($name) -
358}
359
360# platform <os> [<release>] [<arch>]
361# Portfile level procedure to provide support for declaring platform-specifics
362# Basically, just wrap 'variant', so that Portfiles' platform declarations can
363# be more readable, and support arch and version specifics
364proc platform {args} {
365    global all_variants PortInfo os.platform os.arch os.version
366    upvar $args upargs
367   
368    set len [llength $args]
369    set code [lindex $args end]
370    set os [lindex $args 0]
371    set args [lrange $args 1 [expr $len - 2]]
372   
373    set ditem [variant_new "temp-variant"]
374   
375    foreach arg $args {
376        if {[regexp {(^[0-9]$)} $arg match result]} {
377            set release $result
378        } elseif {[regexp {([a-zA-Z0-9]*)} $arg match result]} {
379            set arch $result
380        }
381    }
382   
383    # Add the variant for this platform
384    set platform $os
385    if {[info exists release]} { set platform ${platform}_${release} }
386    if {[info exists arch]} { set platform ${platform}_${arch} }
387   
388    variant $platform $code
389   
390    # Set the variant if this platform matches the platform we're on
391    set matches 1
392    if {[info exists os.platform] && ${os.platform} == $os} { 
393        set sel_platform $os
394        if {[info exists os.version] && [info exists release]} {
395            regexp {([0-9]*)[0-9\.]?} ${os.version} match major
396            if {$major == $release } { 
397                set sel_platform ${sel_platform}_${release} 
398            } else {
399                    set matches 0
400            }
401        }
402        if {$matches == 1 && [info exists arch] && [info exists os.arch]} {
403                if {${os.arch} == $arch} {
404                        set sel_platform ${sel_platform}_${arch}
405                } else {
406                        set matches 0
407                }
408    }
409    if {$matches == 1} {
410        variant_set $sel_platform
411    }
412    }
413}
414
415########### Misc Utility Functions ###########
416
417# tbool (testbool)
418# If the variable exists in the calling procedure's namespace
419# and is set to "yes", return 1. Otherwise, return 0
420proc tbool {key} {
421    upvar $key $key
422    if {[info exists $key]} {
423        if {[string equal -nocase [set $key] "yes"]} {
424            return 1
425        }
426    }
427    return 0
428}
429
430# ldelete
431# Deletes a value from the supplied list
432proc ldelete {list value} {
433    set ix [lsearch -exact $list $value]
434    if {$ix >= 0} {
435        return [lreplace $list $ix $ix]
436    }
437    return $list
438}
439
440# reinplace
441# Provides "sed in place" functionality
442proc reinplace {pattern args}  {
443    if {$args == ""} {
444        ui_error "reinplace: no value given for parameter \"file\""
445        return -code error "no value given for parameter \"file\" to \"reinplace\"" 
446    }
447   
448    foreach file $args {
449        if {[catch {set tmpfile [mkstemp "/tmp/[file tail $file].sed.XXXXXXXX"]} error]} {
450                global errorInfo
451                ui_debug "$errorInfo"
452            ui_error "reinplace: $error"
453            return -code error "reinplace failed"
454        } else {
455            # Extract the Tcl Channel number
456            set tmpfd [lindex $tmpfile 0]
457            # Set tmpfile to only the file name
458            set tmpfile [lindex $tmpfile 1]
459        }
460       
461        if {[catch {exec sed $pattern < $file >@ $tmpfd} error]} {
462                global errorInfo
463                ui_debug "$errorInfo"
464            ui_error "reinplace: $error"
465            file delete "$tmpfile"
466            close $tmpfd
467            return -code error "reinplace sed(1) failed"
468        }
469       
470        close $tmpfd
471       
472        set attributes [file attributes $file]
473        # We need to overwrite this file
474        if {[catch {file attributes $file -permissions u+w} error]} {
475                global errorInfo
476                ui_debug "$errorInfo"
477            ui_error "reinplace: $error"
478            file delete "$tmpfile"
479            return -code error "reinplace permissions failed"
480        }
481       
482        if {[catch {exec cp $tmpfile $file} error]} {
483                global errorInfo
484                ui_debug "$errorInfo"
485            ui_error "reinplace: $error"
486            file delete "$tmpfile"
487            return -code error "reinplace copy failed"
488        }
489       
490        for {set i 0} {$i < [llength attributes]} {incr i} {
491            set opt [lindex $attributes $i]
492            incr i
493            set arg [lindex $attributes $i]
494            file attributes $file $opt $arg
495        }
496       
497        file delete "$tmpfile"
498    }
499    return
500}
501
502# filefindbypath
503# Provides searching of the standard path for included files
504proc filefindbypath {fname} {
505    global distpath filesdir workdir worksrcdir portpath
506   
507    if {[file readable $portpath/$fname]} {
508        return $portpath/$fname
509    } elseif {[file readable $portpath/$filesdir/$fname]} {
510        return $portpath/$filesdir/$fname
511    } elseif {[file readable $distpath/$fname]} {
512        return $distpath/$fname
513    }
514    return ""
515}
516
517# include
518# Source a file, looking for it along a standard search path.
519proc include {fname} {
520    set tgt [filefindbypath $fname]
521    if {[string length $tgt]} {
522        uplevel "source $tgt"
523    } else {
524        return -code error "Unable to find include file $fname"
525    }
526}
527
528# makeuserproc
529# This procedure re-writes the user-defined custom target to include
530# all the globals in its scope.  This is undeniably ugly, but I haven't
531# thought of any other way to do this.
532proc makeuserproc {name body} {
533    regsub -- "^\{(.*?)" $body "\{ \n foreach g \[info globals\] \{ \n global \$g \n \} \n \\1" body
534    eval "proc $name {} $body"
535}
536
537########### Internal Dependancy Manipulation Procedures ###########
538
539proc target_run {ditem} {
540    global target_state_fd portpath portname portversion portrevision portvariants ports_force variations workpath ports_trace PortInfo
541    set result 0
542    set skipped 0
543    set procedure [ditem_key $ditem procedure]
544    if {$procedure != ""} {
545        set name [ditem_key $ditem name]
546       
547        if {[ditem_contains $ditem init]} {
548            set result [catch {[ditem_key $ditem init] $name} errstr]
549        }
550       
551        if { ![info exists portvariants] } {
552                set portvariants ""
553                set vlist [lsort -ascii [array names variations]]
554
555                # Put together variants in the form +foo+bar for the registry
556                foreach v $vlist {
557                        if { ![string equal $v [option os.platform]] && ![string equal $v [option os.arch]] } {
558                                set portvariants "${portvariants}+${v}"
559                        }
560                }
561        }
562
563        if {$result == 0} {
564                # Skip the step if required and explain why through ui_debug.
565                # 1st case: the step was already done (as mentioned in the state file)
566                if {[check_statefile target $name $target_state_fd]} {
567                    ui_debug "Skipping completed $name ($portname)"
568                    set skipped 1
569                # 2nd case: the step is not to always be performed
570                # and this exact port/version/revision/variants is already installed
571                # and user didn't mention -f
572                # and portfile didn't change since installation.
573                } elseif {[ditem_key $ditem runtype] != "always"
574                        && [registry_exists $portname $portversion $portrevision $portvariants]
575                        && !([info exists ports_force] && $ports_force == "yes")} {
576                                               
577                        # Did the Portfile change since installation?
578                        set regref [registry_open $portname $portversion $portrevision $portvariants]
579                       
580                        set installdate [registry_prop_retr $regref date]
581                        if { $installdate != 0
582                                && $installdate < [file mtime ${portpath}/Portfile]} {
583                                ui_debug "Portfile changed since installation"
584                        } else {
585                                # Say we're skipping.
586                                set skipped 1
587                               
588                                ui_debug "Skipping $name ($portname) since this port is already installed"
589                        }
590                       
591                        # Something to close the registry entry may be called here, if it existed.
592                # 3rd case: the same port/version/revision/Variants is already active
593                # and user didn't mention -f
594                } elseif {$name == "com.apple.activate"
595                        && [registry_exists $portname $portversion $portrevision $portvariants]
596                        && !([info exists ports_force] && $ports_force == "yes")} {
597                       
598                        # Is port active?
599                        set regref [registry_open $portname $portversion $portrevision $portvariants]
600                       
601                        if { [registry_prop_retr $regref active] != 0 } {
602                                # Say we're skipping.
603                                set skipped 1
604                               
605                                ui_debug "Skipping $name ($portname) since this port is already active"
606                        }
607                       
608                }
609                       
610                # otherwise execute the task.
611                if {$skipped == 0} {
612                        if {([info exists ports_trace] && $ports_trace == "yes")} {
613                                trace_start $workpath
614                        }
615
616                        # Execute pre-run procedure
617                        if {[ditem_contains $ditem prerun]} {
618                        set result [catch {[ditem_key $ditem prerun] $name} errstr]
619                        }
620                       
621                        if {$result == 0} {
622                        foreach pre [ditem_key $ditem pre] {
623                                ui_debug "Executing $pre"
624                                set result [catch {$pre $name} errstr]
625                                if {$result != 0} { break }
626                        }
627                        }
628                       
629                        if {$result == 0} {
630                        ui_debug "Executing $name ($portname)"
631                        set result [catch {$procedure $name} errstr]
632                        }
633                       
634                        if {$result == 0} {
635                        foreach post [ditem_key $ditem post] {
636                                ui_debug "Executing $post"
637                                set result [catch {$post $name} errstr]
638                                if {$result != 0} { break }
639                        }
640                        }
641                        # Execute post-run procedure
642                        if {[ditem_contains $ditem postrun] && $result == 0} {
643                        set postrun [ditem_key $ditem postrun]
644                        ui_debug "Executing $postrun"
645                        set result [catch {$postrun $name} errstr]
646                        }
647
648                        # Check dependencies.
649                        if {([info exists ports_trace] && $ports_trace == "yes")} {
650                                set depends {}
651                                set deptypes {}
652                               
653                                # Determine deptypes to look for based on target
654                                switch $target {
655                                        configure       { set deptypes "depends_lib" }
656                                       
657                                        build           { set deptypes "depends_lib depends_build" }
658                                       
659                                        destroot        -
660                                        install         -
661                                        archive         -
662                                        pkg                     -
663                                        mpkg            -
664                                        rpmpackage      -
665                                        dpkg            -
666                                        ""                      { set deptypes "depends_lib depends_build depends_run" }
667                                }
668                               
669                                # Gather the dependencies for deptypes
670                                foreach deptype $deptypes {
671                                        # Add to the list of dependencies if the option exists and isn't empty.
672                                        if {[info exists portinfo($deptype)] && $portinfo($deptype) != ""} {
673                                                set depends [concat $depends $portinfo($deptype)]
674                                        }
675                                }
676
677                                # Dependencies are in the form verb:[param:]port
678                                set depsPorts {}
679                                foreach dep $deps {
680                                        # grab the portname portion of the depspec
681                                        set portname [lindex [split $depspec :] end]
682                                        lappend depsPorts $portname
683                                }
684                                trace_check_deps $depsPorts
685                        }
686
687                        if {([info exists ports_trace] && $ports_trace == "yes")} {
688                                trace_stop
689                        }
690                }
691        }
692        if {$result == 0} {
693                # Only write to state file if:
694                # - we indeed performed this step.
695                # - this step is not to always be performed
696                # - this step must be written to file
697                if {$skipped == 0
698            && [ditem_key $ditem runtype] != "always"
699            && [ditem_key $ditem state] != "no"} {
700                write_statefile target $name $target_state_fd
701            }
702        } else {
703            ui_error "Target $name returned: $errstr"
704            set result 1
705        }
706       
707    } else {
708        ui_info "Warning: $name does not have a registered procedure"
709        set result 1
710    }
711   
712    return $result
713}
714
715proc eval_targets {target} {
716    global targets target_state_fd portname
717    set dlist $targets
718   
719    # Select the subset of targets under $target
720    if {$target != ""} {
721        set matches [dlist_search $dlist provides $target]
722       
723        if {[llength $matches] > 0} {
724            set dlist [dlist_append_dependents $dlist [lindex $matches 0] [list]]
725            # Special-case 'all'
726        } elseif {$target != "all"} {
727            ui_error "unknown target: $target"
728            return 1
729        }
730    }
731   
732    # Restore the state from a previous run.
733    set target_state_fd [open_statefile]
734   
735    set dlist [dlist_eval $dlist "" target_run]
736   
737    if {[llength $dlist] > 0} {
738        # somebody broke!
739        set errstring "Warning: the following items did not execute (for $portname):"
740        foreach ditem $dlist {
741            append errstring " [ditem_key $ditem name]"
742        }
743        ui_info $errstring
744        set result 1
745    } else {
746        set result 0
747    }
748   
749    close $target_state_fd
750    return $result
751}
752
753# open_statefile
754# open file to store name of completed targets
755proc open_statefile {args} {
756    global workpath worksymlink portname portpath ports_ignore_older
757   
758    if {![file isdirectory $workpath]} {
759        file mkdir $workpath
760    }
761    # flock Portfile
762    set statefile [file join $workpath .darwinports.${portname}.state]
763    if {[file exists $statefile]} {
764        if {![file writable $statefile]} {
765            return -code error "$statefile is not writable - check permission on port directory"
766        }
767        if {!([info exists ports_ignore_older] && $ports_ignore_older == "yes") && [file mtime $statefile] < [file mtime ${portpath}/Portfile]} {
768            ui_msg "Portfile changed since last build; discarding previous state."
769            #file delete $statefile
770            exec rm -rf [file join $workpath]
771            exec mkdir [file join $workpath]
772        }
773    }
774
775    # Create a symlink to the workpath for port authors
776    if {![file isdirectory $worksymlink]} {
777            exec ln -sf $workpath $worksymlink
778    }
779   
780    set fd [open $statefile a+]
781    if {[catch {flock $fd -exclusive -noblock} result]} {
782        if {"$result" == "EAGAIN"} {
783            ui_msg "Waiting for lock on $statefile"
784        } elseif {"$result" == "EOPNOTSUPP"} {
785            # Locking not supported, just return
786            return $fd
787        } else {
788            return -code error "$result obtaining lock on $statefile"
789        }
790    }
791    flock $fd -exclusive
792    return $fd
793}
794
795# check_statefile
796# Check completed/selected state of target/variant $name
797proc check_statefile {class name fd} {
798    global portpath workdir
799   
800    seek $fd 0
801    while {[gets $fd line] >= 0} {
802        if {$line == "$class: $name"} {
803            return 1
804        }
805    }
806    return 0
807}
808
809# write_statefile
810# Set target $name completed in the state file
811proc write_statefile {class name fd} {
812    if {[check_statefile $class $name $fd]} {
813        return 0
814    }
815    seek $fd 0 end
816    puts $fd "$class: $name"
817    flush $fd
818}
819
820# check_statefile_variants
821# Check that recorded selection of variants match the current selection
822proc check_statefile_variants {variations fd} {
823    upvar $variations upvariations
824   
825    seek $fd 0
826    while {[gets $fd line] >= 0} {
827        if {[regexp "variant: (.*)" $line match name]} {
828            set oldvariations([string range $name 1 end]) [string range $name 0 0]
829        }
830    }
831   
832    set mismatch 0
833    if {[array size oldvariations] > 0} {
834        if {[array size oldvariations] != [array size upvariations]} {
835            set mismatch 1
836        } else {
837            foreach key [array names upvariations *] {
838                if {![info exists oldvariations($key)] || $upvariations($key) != $oldvariations($key)} {
839                    set mismatch 1
840                    break
841                }
842            }
843        }
844    }
845   
846    return $mismatch
847}
848
849########### Port Variants ###########
850
851# Each variant which provides a subset of the requested variations
852# will be chosen.  Returns a list of the selected variants.
853proc choose_variants {dlist variations} {
854    upvar $variations upvariations
855   
856    set selected [list]
857   
858    foreach ditem $dlist {
859        # Enumerate through the provides, tallying the pros and cons.
860        set pros 0
861        set cons 0
862        set ignored 0
863        foreach flavor [ditem_key $ditem provides] {
864            if {[info exists upvariations($flavor)]} {
865                if {$upvariations($flavor) == "+"} {
866                    incr pros
867                } elseif {$upvariations($flavor) == "-"} {
868                    incr cons
869                }
870            } else {
871                incr ignored
872            }
873        }
874       
875        if {$cons > 0} { continue }
876       
877        if {$pros > 0 && $ignored == 0} {
878            lappend selected $ditem
879        }
880    }
881    return $selected
882}
883
884proc variant_run {ditem} {
885    set name [ditem_key $ditem name]
886    ui_debug "Executing variant $name provides [ditem_key $ditem provides]"
887   
888    # test for conflicting variants
889    foreach v [ditem_key $ditem conflicts] {
890        if {[variant_isset $v]} {
891            ui_error "Variant $name conflicts with $v"
892            return 1
893        }
894    }
895   
896    # execute proc with same name as variant.
897    if {[catch "variant-${name}" result]} {
898        global errorInfo
899        ui_debug "$errorInfo"
900        ui_error "Error executing $name: $result"
901        return 1
902    }
903    return 0
904}
905
906proc eval_variants {variations target} {
907    global all_variants ports_force PortInfo
908    set dlist $all_variants
909    set result 0
910    upvar $variations upvariations
911    set chosen [choose_variants $dlist upvariations]
912        set portname $PortInfo(name)
913
914        # Check to make sure the requested variations are available with this
915        # port, if one is not, warn the user and remove the variant from the
916        # array.
917        foreach key [array names upvariations *] {
918                if {![info exists PortInfo(variants)] || 
919                        [lsearch $PortInfo(variants) $key] == -1} {
920                        ui_debug "Requested variant $key is not provided by port $portname."
921                        array unset upvariations $key
922                }
923        }
924
925    # now that we've selected variants, change all provides [a b c] to [a-b-c]
926    # this will eliminate ambiguity between item a, b, and a-b while fulfilling requirments.
927    #foreach obj $dlist {
928    #    $obj set provides [list [join [$obj get provides] -]]
929    #}
930   
931    set newlist [list]
932    foreach variant $chosen {
933                set newlist [dlist_append_dependents $dlist $variant $newlist]
934    }
935   
936    set dlist [dlist_eval $newlist "" variant_run]
937    if {[llength $dlist] > 0} {
938                return 1
939    }
940   
941    # Make sure the variations match those stored in the statefile.
942    # If they don't match, print an error indicating a 'port clean'
943    # should be performed. 
944    # - Skip this test if the statefile is empty.
945    # - Skip this test if performing a clean.
946    # - Skip this test if ports_force was specified.
947   
948    if {$target != "clean" && 
949        !([info exists ports_force] && $ports_force == "yes")} {
950        set state_fd [open_statefile]
951       
952        if {[check_statefile_variants upvariations $state_fd]} {
953            ui_error "Requested variants do not match original selection.\nPlease perform 'port clean $portname' or specify the force option."
954            set result 1
955        } else {
956            # Write variations out to the statefile
957            foreach key [array names upvariations *] {
958                write_statefile variant $upvariations($key)$key $state_fd
959            }
960        }
961       
962        close $state_fd
963    }
964   
965    return $result
966}
967
968# Target class definition.
969
970# constructor for target object
971proc target_new {name procedure} {
972    global targets
973    set ditem [ditem_create]
974   
975    ditem_key $ditem name $name
976    ditem_key $ditem procedure $procedure
977   
978    lappend targets $ditem
979   
980    return $ditem
981}
982
983proc target_provides {ditem args} {
984    global targets
985    # Register the pre-/post- hooks for use in Portfile.
986    # Portfile syntax: pre-fetch { puts "hello world" }
987    # User-code exceptions are caught and returned as a result of the target.
988    # Thus if the user code breaks, dependent targets will not execute.
989    foreach target $args {
990        set origproc [ditem_key $ditem procedure]
991        set ident [ditem_key $ditem name]
992        if {[info commands $target] != ""} {
993            ui_debug "$ident registered provides \'$target\', a pre-existing procedure. Target override will not be provided"
994        } else {
995            eval "proc $target {args} \{ \n\
996                        variable proc_index \n\
997                        set proc_index \[llength \[ditem_key $ditem proc\]\] \n\
998                        ditem_key $ditem procedure proc-${ident}-${target}-\${proc_index}
999                        eval \"proc proc-${ident}-${target}-\${proc_index} \{name\} \{ \n\
1000                                if \{\\\[catch userproc-${ident}-${target}-\${proc_index} result\\\]\} \{ \n\
1001                                        return -code error \\\$result \n\
1002                                \} else \{ \n\
1003                                        return 0 \n\
1004                                \} \n\
1005                        \}\" \n\
1006                        eval \"proc do-$target \{\} \{ $origproc $target\}\" \n\
1007                        makeuserproc userproc-${ident}-${target}-\${proc_index} \$args \n\
1008                \}"
1009        }
1010        eval "proc pre-$target {args} \{ \n\
1011                        variable proc_index \n\
1012                        set proc_index \[llength \[ditem_key $ditem pre\]\] \n\
1013                        ditem_append $ditem pre proc-pre-${ident}-${target}-\${proc_index}
1014                        eval \"proc proc-pre-${ident}-${target}-\${proc_index} \{name\} \{ \n\
1015                                if \{\\\[catch userproc-pre-${ident}-${target}-\${proc_index} result\\\]\} \{ \n\
1016                                        return -code error \\\$result \n\
1017                                \} else \{ \n\
1018                                        return 0 \n\
1019                                \} \n\
1020                        \}\" \n\
1021                        makeuserproc userproc-pre-${ident}-${target}-\${proc_index} \$args \n\
1022                \}"
1023        eval "proc post-$target {args} \{ \n\
1024                        variable proc_index \n\
1025                        set proc_index \[llength \[ditem_key $ditem post\]\] \n\
1026                        ditem_append $ditem post proc-post-${ident}-${target}-\${proc_index}
1027                        eval \"proc proc-post-${ident}-${target}-\${proc_index} \{name\} \{ \n\
1028                                if \{\\\[catch userproc-post-${ident}-${target}-\${proc_index} result\\\]\} \{ \n\
1029                                        return -code error \\\$result \n\
1030                                \} else \{ \n\
1031                                        return 0 \n\
1032                                \} \n\
1033                        \}\" \n\
1034                        makeuserproc userproc-post-${ident}-${target}-\${proc_index} \$args \n\
1035                \}"
1036    }
1037    eval "ditem_append $ditem provides $args"
1038}
1039
1040proc target_requires {ditem args} {
1041    eval "ditem_append $ditem requires $args"
1042}
1043
1044proc target_uses {ditem args} {
1045    eval "ditem_append $ditem uses $args"
1046}
1047
1048proc target_deplist {ditem args} {
1049    eval "ditem_append $ditem deplist $args"
1050}
1051
1052proc target_prerun {ditem args} {
1053    eval "ditem_append $ditem prerun $args"
1054}
1055
1056proc target_postrun {ditem args} {
1057    eval "ditem_append $ditem postrun $args"
1058}
1059
1060proc target_runtype {ditem args} {
1061    eval "ditem_append $ditem runtype $args"
1062}
1063
1064proc target_state {ditem args} {
1065    eval "ditem_append $ditem state $args"
1066}
1067
1068proc target_init {ditem args} {
1069    eval "ditem_append $ditem init $args"
1070}
1071
1072##### variant class #####
1073
1074# constructor for variant objects
1075proc variant_new {name} {
1076    set ditem [ditem_create]
1077    ditem_key $ditem name $name
1078    return $ditem
1079}
1080
1081proc handle_default_variants {option action args} {
1082    global variations
1083    switch -regex $action {
1084        set|append {
1085            foreach v $args {
1086                if {[regexp {([-+])([-A-Za-z0-9_]+)} $v whole val variant]} {
1087                    if {![info exists variations($variant)]} {
1088                        set variations($variant) $val
1089                    }
1090                }
1091            }
1092        }
1093        delete {
1094            # xxx
1095        }
1096    }
1097}
1098
1099
1100# builds the specified port (looked up in the index) to the specified target
1101# doesn't yet support options or variants...
1102# newworkpath defines the port's workpath - useful for when one port relies
1103# on the source, etc, of another
1104proc portexec_int {portname target {newworkpath ""}} {
1105    ui_debug "Executing $target ($portname)"
1106    set variations [list]
1107    if {$newworkpath == ""} {
1108        array set options [list]
1109    } else {
1110        set options(workpath) ${newworkpath}
1111    }
1112    # Escape regex special characters
1113    regsub -all "(\\(){1}|(\\)){1}|(\\{1}){1}|(\\+){1}|(\\{1}){1}|(\\{){1}|(\\}){1}|(\\^){1}|(\\$){1}|(\\.){1}|(\\\\){1}" $portname "\\\\&" search_string
1114   
1115    set res [dport_search ^$search_string\$]
1116    if {[llength $res] < 2} {
1117        ui_error "Dependency $portname not found"
1118        return -1
1119    }
1120   
1121    array set portinfo [lindex $res 1]
1122    set porturl $portinfo(porturl)
1123    if {[catch {set worker [dport_open $porturl [array get options] $variations]} result]} {
1124                global errorInfo
1125                ui_debug "$errorInfo"
1126        ui_error "Opening $portname $target failed: $result"
1127        return -1
1128    }
1129    if {[catch {dport_exec $worker $target} result] || $result != 0} {
1130                global errorInfo
1131                ui_debug "$errorInfo"
1132        ui_error "Execution $portname $target failed: $result"
1133        dport_close $worker
1134        return -1
1135    }
1136    dport_close $worker
1137   
1138    return 0
1139}
1140
1141# portfile primitive that calls portexec_int with newworkpath == ${workpath}
1142proc portexec {portname target} {
1143    global workpath
1144    return [portexec_int $portname $target $workpath]
1145}
1146
1147proc adduser {name args} {
1148    global os.platform
1149    set passwd {\*}
1150    set uid [nextuid]
1151    set gid [existsgroup nogroup]
1152    set realname ${name}
1153    set home /dev/null
1154    set shell /dev/null
1155   
1156    foreach arg $args {
1157        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
1158            regsub -all " " ${val} "\\ " val
1159            set $key $val
1160        }
1161    }
1162   
1163    if {[existsuser ${name}] != 0 || [existsuser ${uid}] != 0} {
1164        return
1165    }
1166   
1167    if {${os.platform} == "darwin"} {
1168        system "niutil -create . /users/${name}"
1169        system "niutil -createprop . /users/${name} name ${name}"
1170        system "niutil -createprop . /users/${name} passwd ${passwd}"
1171        system "niutil -createprop . /users/${name} uid ${uid}"
1172        system "niutil -createprop . /users/${name} gid ${gid}"
1173        system "niutil -createprop . /users/${name} realname ${realname}"
1174        system "niutil -createprop . /users/${name} home ${home}"
1175        system "niutil -createprop . /users/${name} shell ${shell}"
1176    } else {
1177        # XXX adduser is only available for darwin, add more support here
1178        ui_warn "WARNING: adduser is not implemented on ${os.platform}."
1179        ui_warn "The requested user was not created."
1180    }
1181}
1182
1183proc addgroup {name args} {
1184    global os.platform
1185    set gid [nextgid]
1186    set passwd {\*}
1187    set users ""
1188   
1189    foreach arg $args {
1190        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
1191            regsub -all " " ${val} "\\ " val
1192            set $key $val
1193        }
1194    }
1195   
1196    if {[existsgroup ${name}] != 0 || [existsgroup ${gid}] != 0} {
1197        return
1198    }
1199   
1200    if {${os.platform} == "darwin"} {
1201        system "niutil -create . /groups/${name}"
1202        system "niutil -createprop . /groups/${name} name ${name}"
1203        system "niutil -createprop . /groups/${name} gid ${gid}"
1204        system "niutil -createprop . /groups/${name} passwd ${passwd}"
1205        system "niutil -createprop . /groups/${name} users ${users}"
1206    } else {
1207        # XXX addgroup is only available for darwin, add more support here
1208        ui_warn "WARNING: addgroup is not implemented on ${os.platform}."
1209        ui_warn "The requested group was not created."
1210    }
1211}
1212
1213# proc to calculate size of a directory
1214# moved here from portpkg.tcl
1215proc dirSize {dir} {
1216    set size    0;
1217    foreach file [readdir $dir] {
1218        if {[file type [file join $dir $file]] == "link" } {
1219            continue
1220        }
1221        if {[file isdirectory [file join $dir $file]]} {
1222            incr size [dirSize [file join $dir $file]]
1223        } else {
1224            incr size [file size [file join $dir $file]];
1225        }
1226    }
1227    return $size;
1228}
1229
1230# check for a binary in the path
1231# returns an error code if it can not be found
1232proc binaryInPath {binary} {
1233    global env
1234    foreach dir [split $env(PATH) :] { 
1235        if {[file executable [file join $dir $binary]]} {
1236            return [file join $dir $binary]
1237        }
1238    }
1239   
1240    return -code error [format [msgcat::mc "Failed to locate '%s' in path: '%s'"] $binary $env(PATH)];
1241}
1242
1243# Set the UI prefix to something standard (so it can be grepped for in output)
1244proc set_ui_prefix {} {
1245        global UI_PREFIX env
1246        if {[info exists env(UI_PREFIX)]} {
1247                set UI_PREFIX $env(UI_PREFIX)
1248        } else {
1249                set UI_PREFIX "---> "
1250        }
1251}
1252
1253# Use a specified group/version.
1254proc PortGroup {group version} {
1255        global portresourcepath
1256
1257        set groupFile ${portresourcepath}/group/${group}-${version}.tcl
1258
1259        if {[file exists $groupFile]} {
1260                uplevel "source $groupFile"
1261        } else {
1262                ui_warn "Group file could not be located."
1263        }
1264}
1265
1266# check if archive type is supported by current system
1267# returns an error code if it is not
1268proc archiveTypeIsSupported {type} {
1269    global os.platform os.version
1270        set errmsg ""
1271        switch -regex $type {
1272                cp(io|gz) {
1273                        set pax "pax"
1274                        if {[catch {set pax [binaryInPath $pax]} errmsg] == 0} {
1275                                if {[regexp {z$} $type]} {
1276                                        set gzip "gzip"
1277                                        if {[catch {set gzip [binaryInPath $gzip]} errmsg] == 0} {
1278                                                return 0
1279                                        }
1280                                } else {
1281                                        return 0
1282                                }
1283                        }
1284                }
1285                t(ar|gz) {
1286                        set tar "tar"
1287                        if {[catch {set tar [binaryInPath $tar]} errmsg] == 0} {
1288                                if {[regexp {z$} $type]} {
1289                                        set gzip "gzip"
1290                                        if {[catch {set gzip [binaryInPath $gzip]} errmsg] == 0} {
1291                                                return 0
1292                                        }
1293                                } else {
1294                                        return 0
1295                                }
1296                        }
1297                }
1298                xar {
1299                        set xar "xar"
1300                        if {[catch {set xar [binaryInPath $xar]} errmsg] == 0} {
1301                                return 0
1302                        }
1303                }
1304                zip {
1305                        set zip "zip"
1306                        if {[catch {set zip [binaryInPath $zip]} errmsg] == 0} {
1307                                set unzip "unzip"
1308                                if {[catch {set unzip [binaryInPath $unzip]} errmsg] == 0} {
1309                                        return 0
1310                                }
1311                        }
1312                }
1313                default {
1314                        return -code error [format [msgcat::mc "Invalid port archive type '%s' specified!"] $type]
1315                }
1316        }
1317        return -code error [format [msgcat::mc "Unsupported port archive type '%s': %s"] $type $errmsg]
1318}
1319
Note: See TracBrowser for help on using the repository browser.