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

Last change on this file since 13403 was 13403, checked in by pguyot (Paul Guyot), 14 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.