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

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

option -t update : now creations (and file write) outside workpath, and
temporary directories are forbidden (instead of just being reported).

Notes:

file deletion aren't forbidden.
there are other ways to alter the filesystem that aren't trapped and watched.

This works with the following changes:

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