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

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

Fixed bad logic that prevented ignoring of some steps for the file creation.

  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 37.4 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 & file creations outside workpath.
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                                set target [ditem_key $ditem provides]
655                                switch $target {
656                                        configure       { set deptypes "depends_lib" }
657                                       
658                                        build           { set deptypes "depends_lib depends_build" }
659                                       
660                                        destroot        -
661                                        install         -
662                                        archive         -
663                                        pkg                     -
664                                        mpkg            -
665                                        rpmpackage      -
666                                        dpkg            -
667                                        ""                      { set deptypes "depends_lib depends_build depends_run" }
668                                }
669                               
670                                # Gather the dependencies for deptypes
671                                foreach deptype $deptypes {
672                                        # Add to the list of dependencies if the option exists and isn't empty.
673                                        if {[info exists portinfo($deptype)] && $portinfo($deptype) != ""} {
674                                                set depends [concat $depends $portinfo($deptype)]
675                                        }
676                                }
677
678                                # Dependencies are in the form verb:[param:]port
679                                set depsPorts {}
680                                foreach dep $depends {
681                                        # grab the portname portion of the depspec
682                                        set portname [lindex [split $depspec :] end]
683                                        lappend depsPorts $portname
684                                }
685                                trace_check_deps $depsPorts
686                               
687                                # Check files that were created.
688                                if {$target != "activate"
689                                        && $target != "fetch"
690                                        && $target != "install"} {
691                                        trace_check_create
692                                }
693                        }
694
695                        if {([info exists ports_trace] && $ports_trace == "yes")} {
696                                trace_stop
697                        }
698                }
699        }
700        if {$result == 0} {
701                # Only write to state file if:
702                # - we indeed performed this step.
703                # - this step is not to always be performed
704                # - this step must be written to file
705                if {$skipped == 0
706            && [ditem_key $ditem runtype] != "always"
707            && [ditem_key $ditem state] != "no"} {
708                write_statefile target $name $target_state_fd
709            }
710        } else {
711            ui_error "Target $name returned: $errstr"
712            set result 1
713        }
714       
715    } else {
716        ui_info "Warning: $name does not have a registered procedure"
717        set result 1
718    }
719   
720    return $result
721}
722
723proc eval_targets {target} {
724    global targets target_state_fd portname
725    set dlist $targets
726   
727    # Select the subset of targets under $target
728    if {$target != ""} {
729        set matches [dlist_search $dlist provides $target]
730       
731        if {[llength $matches] > 0} {
732            set dlist [dlist_append_dependents $dlist [lindex $matches 0] [list]]
733            # Special-case 'all'
734        } elseif {$target != "all"} {
735            ui_error "unknown target: $target"
736            return 1
737        }
738    }
739   
740    # Restore the state from a previous run.
741    set target_state_fd [open_statefile]
742   
743    set dlist [dlist_eval $dlist "" target_run]
744   
745    if {[llength $dlist] > 0} {
746        # somebody broke!
747        set errstring "Warning: the following items did not execute (for $portname):"
748        foreach ditem $dlist {
749            append errstring " [ditem_key $ditem name]"
750        }
751        ui_info $errstring
752        set result 1
753    } else {
754        set result 0
755    }
756   
757    close $target_state_fd
758    return $result
759}
760
761# open_statefile
762# open file to store name of completed targets
763proc open_statefile {args} {
764    global workpath worksymlink portname portpath ports_ignore_older
765   
766    if {![file isdirectory $workpath]} {
767        file mkdir $workpath
768    }
769    # flock Portfile
770    set statefile [file join $workpath .darwinports.${portname}.state]
771    if {[file exists $statefile]} {
772        if {![file writable $statefile]} {
773            return -code error "$statefile is not writable - check permission on port directory"
774        }
775        if {!([info exists ports_ignore_older] && $ports_ignore_older == "yes") && [file mtime $statefile] < [file mtime ${portpath}/Portfile]} {
776            ui_msg "Portfile changed since last build; discarding previous state."
777            #file delete $statefile
778            exec rm -rf [file join $workpath]
779            exec mkdir [file join $workpath]
780        }
781    }
782
783    # Create a symlink to the workpath for port authors
784    if {![file isdirectory $worksymlink]} {
785            exec ln -sf $workpath $worksymlink
786    }
787   
788    set fd [open $statefile a+]
789    if {[catch {flock $fd -exclusive -noblock} result]} {
790        if {"$result" == "EAGAIN"} {
791            ui_msg "Waiting for lock on $statefile"
792        } elseif {"$result" == "EOPNOTSUPP"} {
793            # Locking not supported, just return
794            return $fd
795        } else {
796            return -code error "$result obtaining lock on $statefile"
797        }
798    }
799    flock $fd -exclusive
800    return $fd
801}
802
803# check_statefile
804# Check completed/selected state of target/variant $name
805proc check_statefile {class name fd} {
806    global portpath workdir
807   
808    seek $fd 0
809    while {[gets $fd line] >= 0} {
810        if {$line == "$class: $name"} {
811            return 1
812        }
813    }
814    return 0
815}
816
817# write_statefile
818# Set target $name completed in the state file
819proc write_statefile {class name fd} {
820    if {[check_statefile $class $name $fd]} {
821        return 0
822    }
823    seek $fd 0 end
824    puts $fd "$class: $name"
825    flush $fd
826}
827
828# check_statefile_variants
829# Check that recorded selection of variants match the current selection
830proc check_statefile_variants {variations fd} {
831    upvar $variations upvariations
832   
833    seek $fd 0
834    while {[gets $fd line] >= 0} {
835        if {[regexp "variant: (.*)" $line match name]} {
836            set oldvariations([string range $name 1 end]) [string range $name 0 0]
837        }
838    }
839   
840    set mismatch 0
841    if {[array size oldvariations] > 0} {
842        if {[array size oldvariations] != [array size upvariations]} {
843            set mismatch 1
844        } else {
845            foreach key [array names upvariations *] {
846                if {![info exists oldvariations($key)] || $upvariations($key) != $oldvariations($key)} {
847                    set mismatch 1
848                    break
849                }
850            }
851        }
852    }
853   
854    return $mismatch
855}
856
857########### Port Variants ###########
858
859# Each variant which provides a subset of the requested variations
860# will be chosen.  Returns a list of the selected variants.
861proc choose_variants {dlist variations} {
862    upvar $variations upvariations
863   
864    set selected [list]
865   
866    foreach ditem $dlist {
867        # Enumerate through the provides, tallying the pros and cons.
868        set pros 0
869        set cons 0
870        set ignored 0
871        foreach flavor [ditem_key $ditem provides] {
872            if {[info exists upvariations($flavor)]} {
873                if {$upvariations($flavor) == "+"} {
874                    incr pros
875                } elseif {$upvariations($flavor) == "-"} {
876                    incr cons
877                }
878            } else {
879                incr ignored
880            }
881        }
882       
883        if {$cons > 0} { continue }
884       
885        if {$pros > 0 && $ignored == 0} {
886            lappend selected $ditem
887        }
888    }
889    return $selected
890}
891
892proc variant_run {ditem} {
893    set name [ditem_key $ditem name]
894    ui_debug "Executing variant $name provides [ditem_key $ditem provides]"
895   
896    # test for conflicting variants
897    foreach v [ditem_key $ditem conflicts] {
898        if {[variant_isset $v]} {
899            ui_error "Variant $name conflicts with $v"
900            return 1
901        }
902    }
903   
904    # execute proc with same name as variant.
905    if {[catch "variant-${name}" result]} {
906        global errorInfo
907        ui_debug "$errorInfo"
908        ui_error "Error executing $name: $result"
909        return 1
910    }
911    return 0
912}
913
914proc eval_variants {variations target} {
915    global all_variants ports_force PortInfo
916    set dlist $all_variants
917    set result 0
918    upvar $variations upvariations
919    set chosen [choose_variants $dlist upvariations]
920        set portname $PortInfo(name)
921
922        # Check to make sure the requested variations are available with this
923        # port, if one is not, warn the user and remove the variant from the
924        # array.
925        foreach key [array names upvariations *] {
926                if {![info exists PortInfo(variants)] || 
927                        [lsearch $PortInfo(variants) $key] == -1} {
928                        ui_debug "Requested variant $key is not provided by port $portname."
929                        array unset upvariations $key
930                }
931        }
932
933    # now that we've selected variants, change all provides [a b c] to [a-b-c]
934    # this will eliminate ambiguity between item a, b, and a-b while fulfilling requirments.
935    #foreach obj $dlist {
936    #    $obj set provides [list [join [$obj get provides] -]]
937    #}
938   
939    set newlist [list]
940    foreach variant $chosen {
941                set newlist [dlist_append_dependents $dlist $variant $newlist]
942    }
943   
944    set dlist [dlist_eval $newlist "" variant_run]
945    if {[llength $dlist] > 0} {
946                return 1
947    }
948   
949    # Make sure the variations match those stored in the statefile.
950    # If they don't match, print an error indicating a 'port clean'
951    # should be performed. 
952    # - Skip this test if the statefile is empty.
953    # - Skip this test if performing a clean.
954    # - Skip this test if ports_force was specified.
955   
956    if {$target != "clean" && 
957        !([info exists ports_force] && $ports_force == "yes")} {
958        set state_fd [open_statefile]
959       
960        if {[check_statefile_variants upvariations $state_fd]} {
961            ui_error "Requested variants do not match original selection.\nPlease perform 'port clean $portname' or specify the force option."
962            set result 1
963        } else {
964            # Write variations out to the statefile
965            foreach key [array names upvariations *] {
966                write_statefile variant $upvariations($key)$key $state_fd
967            }
968        }
969       
970        close $state_fd
971    }
972   
973    return $result
974}
975
976# Target class definition.
977
978# constructor for target object
979proc target_new {name procedure} {
980    global targets
981    set ditem [ditem_create]
982   
983    ditem_key $ditem name $name
984    ditem_key $ditem procedure $procedure
985   
986    lappend targets $ditem
987   
988    return $ditem
989}
990
991proc target_provides {ditem args} {
992    global targets
993    # Register the pre-/post- hooks for use in Portfile.
994    # Portfile syntax: pre-fetch { puts "hello world" }
995    # User-code exceptions are caught and returned as a result of the target.
996    # Thus if the user code breaks, dependent targets will not execute.
997    foreach target $args {
998        set origproc [ditem_key $ditem procedure]
999        set ident [ditem_key $ditem name]
1000        if {[info commands $target] != ""} {
1001            ui_debug "$ident registered provides \'$target\', a pre-existing procedure. Target override will not be provided"
1002        } else {
1003            eval "proc $target {args} \{ \n\
1004                        variable proc_index \n\
1005                        set proc_index \[llength \[ditem_key $ditem proc\]\] \n\
1006                        ditem_key $ditem procedure proc-${ident}-${target}-\${proc_index}
1007                        eval \"proc proc-${ident}-${target}-\${proc_index} \{name\} \{ \n\
1008                                if \{\\\[catch userproc-${ident}-${target}-\${proc_index} result\\\]\} \{ \n\
1009                                        return -code error \\\$result \n\
1010                                \} else \{ \n\
1011                                        return 0 \n\
1012                                \} \n\
1013                        \}\" \n\
1014                        eval \"proc do-$target \{\} \{ $origproc $target\}\" \n\
1015                        makeuserproc userproc-${ident}-${target}-\${proc_index} \$args \n\
1016                \}"
1017        }
1018        eval "proc pre-$target {args} \{ \n\
1019                        variable proc_index \n\
1020                        set proc_index \[llength \[ditem_key $ditem pre\]\] \n\
1021                        ditem_append $ditem pre proc-pre-${ident}-${target}-\${proc_index}
1022                        eval \"proc proc-pre-${ident}-${target}-\${proc_index} \{name\} \{ \n\
1023                                if \{\\\[catch userproc-pre-${ident}-${target}-\${proc_index} result\\\]\} \{ \n\
1024                                        return -code error \\\$result \n\
1025                                \} else \{ \n\
1026                                        return 0 \n\
1027                                \} \n\
1028                        \}\" \n\
1029                        makeuserproc userproc-pre-${ident}-${target}-\${proc_index} \$args \n\
1030                \}"
1031        eval "proc post-$target {args} \{ \n\
1032                        variable proc_index \n\
1033                        set proc_index \[llength \[ditem_key $ditem post\]\] \n\
1034                        ditem_append $ditem post proc-post-${ident}-${target}-\${proc_index}
1035                        eval \"proc proc-post-${ident}-${target}-\${proc_index} \{name\} \{ \n\
1036                                if \{\\\[catch userproc-post-${ident}-${target}-\${proc_index} result\\\]\} \{ \n\
1037                                        return -code error \\\$result \n\
1038                                \} else \{ \n\
1039                                        return 0 \n\
1040                                \} \n\
1041                        \}\" \n\
1042                        makeuserproc userproc-post-${ident}-${target}-\${proc_index} \$args \n\
1043                \}"
1044    }
1045    eval "ditem_append $ditem provides $args"
1046}
1047
1048proc target_requires {ditem args} {
1049    eval "ditem_append $ditem requires $args"
1050}
1051
1052proc target_uses {ditem args} {
1053    eval "ditem_append $ditem uses $args"
1054}
1055
1056proc target_deplist {ditem args} {
1057    eval "ditem_append $ditem deplist $args"
1058}
1059
1060proc target_prerun {ditem args} {
1061    eval "ditem_append $ditem prerun $args"
1062}
1063
1064proc target_postrun {ditem args} {
1065    eval "ditem_append $ditem postrun $args"
1066}
1067
1068proc target_runtype {ditem args} {
1069    eval "ditem_append $ditem runtype $args"
1070}
1071
1072proc target_state {ditem args} {
1073    eval "ditem_append $ditem state $args"
1074}
1075
1076proc target_init {ditem args} {
1077    eval "ditem_append $ditem init $args"
1078}
1079
1080##### variant class #####
1081
1082# constructor for variant objects
1083proc variant_new {name} {
1084    set ditem [ditem_create]
1085    ditem_key $ditem name $name
1086    return $ditem
1087}
1088
1089proc handle_default_variants {option action args} {
1090    global variations
1091    switch -regex $action {
1092        set|append {
1093            foreach v $args {
1094                if {[regexp {([-+])([-A-Za-z0-9_]+)} $v whole val variant]} {
1095                    if {![info exists variations($variant)]} {
1096                        set variations($variant) $val
1097                    }
1098                }
1099            }
1100        }
1101        delete {
1102            # xxx
1103        }
1104    }
1105}
1106
1107
1108# builds the specified port (looked up in the index) to the specified target
1109# doesn't yet support options or variants...
1110# newworkpath defines the port's workpath - useful for when one port relies
1111# on the source, etc, of another
1112proc portexec_int {portname target {newworkpath ""}} {
1113    ui_debug "Executing $target ($portname)"
1114    set variations [list]
1115    if {$newworkpath == ""} {
1116        array set options [list]
1117    } else {
1118        set options(workpath) ${newworkpath}
1119    }
1120    # Escape regex special characters
1121    regsub -all "(\\(){1}|(\\)){1}|(\\{1}){1}|(\\+){1}|(\\{1}){1}|(\\{){1}|(\\}){1}|(\\^){1}|(\\$){1}|(\\.){1}|(\\\\){1}" $portname "\\\\&" search_string
1122   
1123    set res [dport_search ^$search_string\$]
1124    if {[llength $res] < 2} {
1125        ui_error "Dependency $portname not found"
1126        return -1
1127    }
1128   
1129    array set portinfo [lindex $res 1]
1130    set porturl $portinfo(porturl)
1131    if {[catch {set worker [dport_open $porturl [array get options] $variations]} result]} {
1132                global errorInfo
1133                ui_debug "$errorInfo"
1134        ui_error "Opening $portname $target failed: $result"
1135        return -1
1136    }
1137    if {[catch {dport_exec $worker $target} result] || $result != 0} {
1138                global errorInfo
1139                ui_debug "$errorInfo"
1140        ui_error "Execution $portname $target failed: $result"
1141        dport_close $worker
1142        return -1
1143    }
1144    dport_close $worker
1145   
1146    return 0
1147}
1148
1149# portfile primitive that calls portexec_int with newworkpath == ${workpath}
1150proc portexec {portname target} {
1151    global workpath
1152    return [portexec_int $portname $target $workpath]
1153}
1154
1155proc adduser {name args} {
1156    global os.platform
1157    set passwd {\*}
1158    set uid [nextuid]
1159    set gid [existsgroup nogroup]
1160    set realname ${name}
1161    set home /dev/null
1162    set shell /dev/null
1163   
1164    foreach arg $args {
1165        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
1166            regsub -all " " ${val} "\\ " val
1167            set $key $val
1168        }
1169    }
1170   
1171    if {[existsuser ${name}] != 0 || [existsuser ${uid}] != 0} {
1172        return
1173    }
1174   
1175    if {${os.platform} == "darwin"} {
1176        system "niutil -create . /users/${name}"
1177        system "niutil -createprop . /users/${name} name ${name}"
1178        system "niutil -createprop . /users/${name} passwd ${passwd}"
1179        system "niutil -createprop . /users/${name} uid ${uid}"
1180        system "niutil -createprop . /users/${name} gid ${gid}"
1181        system "niutil -createprop . /users/${name} realname ${realname}"
1182        system "niutil -createprop . /users/${name} home ${home}"
1183        system "niutil -createprop . /users/${name} shell ${shell}"
1184    } else {
1185        # XXX adduser is only available for darwin, add more support here
1186        ui_warn "WARNING: adduser is not implemented on ${os.platform}."
1187        ui_warn "The requested user was not created."
1188    }
1189}
1190
1191proc addgroup {name args} {
1192    global os.platform
1193    set gid [nextgid]
1194    set passwd {\*}
1195    set users ""
1196   
1197    foreach arg $args {
1198        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
1199            regsub -all " " ${val} "\\ " val
1200            set $key $val
1201        }
1202    }
1203   
1204    if {[existsgroup ${name}] != 0 || [existsgroup ${gid}] != 0} {
1205        return
1206    }
1207   
1208    if {${os.platform} == "darwin"} {
1209        system "niutil -create . /groups/${name}"
1210        system "niutil -createprop . /groups/${name} name ${name}"
1211        system "niutil -createprop . /groups/${name} gid ${gid}"
1212        system "niutil -createprop . /groups/${name} passwd ${passwd}"
1213        system "niutil -createprop . /groups/${name} users ${users}"
1214    } else {
1215        # XXX addgroup is only available for darwin, add more support here
1216        ui_warn "WARNING: addgroup is not implemented on ${os.platform}."
1217        ui_warn "The requested group was not created."
1218    }
1219}
1220
1221# proc to calculate size of a directory
1222# moved here from portpkg.tcl
1223proc dirSize {dir} {
1224    set size    0;
1225    foreach file [readdir $dir] {
1226        if {[file type [file join $dir $file]] == "link" } {
1227            continue
1228        }
1229        if {[file isdirectory [file join $dir $file]]} {
1230            incr size [dirSize [file join $dir $file]]
1231        } else {
1232            incr size [file size [file join $dir $file]];
1233        }
1234    }
1235    return $size;
1236}
1237
1238# check for a binary in the path
1239# returns an error code if it can not be found
1240proc binaryInPath {binary} {
1241    global env
1242    foreach dir [split $env(PATH) :] { 
1243        if {[file executable [file join $dir $binary]]} {
1244            return [file join $dir $binary]
1245        }
1246    }
1247   
1248    return -code error [format [msgcat::mc "Failed to locate '%s' in path: '%s'"] $binary $env(PATH)];
1249}
1250
1251# Set the UI prefix to something standard (so it can be grepped for in output)
1252proc set_ui_prefix {} {
1253        global UI_PREFIX env
1254        if {[info exists env(UI_PREFIX)]} {
1255                set UI_PREFIX $env(UI_PREFIX)
1256        } else {
1257                set UI_PREFIX "---> "
1258        }
1259}
1260
1261# Use a specified group/version.
1262proc PortGroup {group version} {
1263        global portresourcepath
1264
1265        set groupFile ${portresourcepath}/group/${group}-${version}.tcl
1266
1267        if {[file exists $groupFile]} {
1268                uplevel "source $groupFile"
1269        } else {
1270                ui_warn "Group file could not be located."
1271        }
1272}
1273
1274# check if archive type is supported by current system
1275# returns an error code if it is not
1276proc archiveTypeIsSupported {type} {
1277    global os.platform os.version
1278        set errmsg ""
1279        switch -regex $type {
1280                cp(io|gz) {
1281                        set pax "pax"
1282                        if {[catch {set pax [binaryInPath $pax]} errmsg] == 0} {
1283                                if {[regexp {z$} $type]} {
1284                                        set gzip "gzip"
1285                                        if {[catch {set gzip [binaryInPath $gzip]} errmsg] == 0} {
1286                                                return 0
1287                                        }
1288                                } else {
1289                                        return 0
1290                                }
1291                        }
1292                }
1293                t(ar|gz) {
1294                        set tar "tar"
1295                        if {[catch {set tar [binaryInPath $tar]} errmsg] == 0} {
1296                                if {[regexp {z$} $type]} {
1297                                        set gzip "gzip"
1298                                        if {[catch {set gzip [binaryInPath $gzip]} errmsg] == 0} {
1299                                                return 0
1300                                        }
1301                                } else {
1302                                        return 0
1303                                }
1304                        }
1305                }
1306                xar {
1307                        set xar "xar"
1308                        if {[catch {set xar [binaryInPath $xar]} errmsg] == 0} {
1309                                return 0
1310                        }
1311                }
1312                zip {
1313                        set zip "zip"
1314                        if {[catch {set zip [binaryInPath $zip]} errmsg] == 0} {
1315                                set unzip "unzip"
1316                                if {[catch {set unzip [binaryInPath $unzip]} errmsg] == 0} {
1317                                        return 0
1318                                }
1319                        }
1320                }
1321                default {
1322                        return -code error [format [msgcat::mc "Invalid port archive type '%s' specified!"] $type]
1323                }
1324        }
1325        return -code error [format [msgcat::mc "Unsupported port archive type '%s': %s"] $type $errmsg]
1326}
1327
Note: See TracBrowser for help on using the repository browser.