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

Last change on this file since 22003 was 22003, checked in by eridius@…, 11 years ago

src/port1.0/* files need not be executable

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