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

Last change on this file since 18726 was 18726, checked in by pguyot, 11 years ago

Don't report undeclared dependencies with the extract target, since there's no
way to declare a dependency for the extract target anyway.

This avoids unwanted warnings with bzip2 port (as use_bzip2 will take any bzip2
in path and therefore the one from DP if it's installed).

On the long-run, we might want to specify the path to bzip2 at configure time
or support dependencies for extract.

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