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

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

Suffixes are supported in patchfiles specifications, but the patch command
actually didn't parse the filename and didn't even warn when the patch is not
applied because it cannot be found.

This change fixes that by:

  • moving the distname and disttag-related functions to portutil.tcl
  • fixing portfetch.tcl to actually end up with an error if a patch file cannot

be found (instead of silently ignoring it)

  • fixing portfetch.tcl to actually consider the distname part of the patch files

instead of the whole entry with the optional tag.

  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 38.0 KB
Line 
1# et:ts=4
2# portutil.tcl
3# $Id: portutil.tcl,v 1.191 2006/04/30 05:32:52 pguyot Exp $
4#
5# Copyright (c) 2004 Robert Shaw <rshaw@opendarwin.org>
6# Copyright (c) 2002 Apple Computer, Inc.
7# All rights reserved.
8#
9# Redistribution and use in source and binary forms, with or without
10# modification, are permitted provided that the following conditions
11# are met:
12# 1. Redistributions of source code must retain the above copyright
13#    notice, this list of conditions and the following disclaimer.
14# 2. Redistributions in binary form must reproduce the above copyright
15#    notice, this list of conditions and the following disclaimer in the
16#    documentation and/or other materials provided with the distribution.
17# 3. Neither the name of Apple Computer, Inc. nor the names of its contributors
18#    may be used to endorse or promote products derived from this software
19#    without specific prior written permission.
20#
21# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
22# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
23# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
24# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
25# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
26# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
27# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
28# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
29# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
30# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
31# POSSIBILITY OF SUCH DAMAGE.
32#
33
34package provide portutil 1.0
35package require Pextlib 1.0
36package require darwinports_dlist 1.0
37package require msgcat
38package require porttrace 1.0
39
40global targets target_uniqid all_variants
41
42set targets [list]
43set target_uniqid 0
44
45set all_variants [list]
46
47########### External High Level Procedures ###########
48
49namespace eval options {
50}
51
52# option
53# This is an accessor for Portfile options.  Targets may use
54# this in the same style as the standard Tcl "set" procedure.
55#       name  - the name of the option to read or write
56#       value - an optional value to assign to the option
57
58proc option {name args} {
59    # XXX: right now we just transparently use globals
60    # eventually this will need to bridge the options between
61    # the Portfile's interpreter and the target's interpreters.
62    global $name
63    if {[llength $args] > 0} {
64        ui_debug "setting option $name to $args"
65        set $name [lindex $args 0]
66    }
67    return [set $name]
68}
69
70# exists
71# This is an accessor for Portfile options.  Targets may use
72# this procedure to test for the existence of a Portfile option.
73#       name - the name of the option to test for existence
74
75proc exists {name} {
76    # XXX: right now we just transparently use globals
77    # eventually this will need to bridge the options between
78    # the Portfile's interpreter and the target's interpreters.
79    global $name
80    return [info exists $name]
81}
82
83# options
84# Exports options in an array as externally callable procedures
85# Thus, "options name date" would create procedures named "name"
86# and "date" that set global variables "name" and "date", respectively
87# When an option is modified in any way, options::$option is called,
88# if it exists
89# Arguments: <list of options>
90proc options {args} {
91    foreach option $args {
92        eval "proc $option {args} \{ \n\
93            global ${option} user_options option_procs \n\
94                \if \{!\[info exists user_options(${option})\]\} \{ \n\
95                     set ${option} \$args \n\
96                \} \n\
97        \}"
98       
99        eval "proc ${option}-delete {args} \{ \n\
100            global ${option} user_options option_procs \n\
101                \if \{!\[info exists user_options(${option})\]\ && \[info exists ${option}\]\} \{ \n\
102                    foreach val \$args \{ \n\
103                       set ${option} \[ldelete \$\{$option\} \$val\] \n\
104                    \} \n\
105                    if \{\[string length \$\{${option}\}\] == 0\} \{ \n\
106                        unset ${option} \n\
107                    \} \n\
108                \} \n\
109        \}"
110        eval "proc ${option}-append {args} \{ \n\
111            global ${option} user_options option_procs \n\
112                \if \{!\[info exists user_options(${option})\]\} \{ \n\
113                    if \{\[info exists ${option}\]\} \{ \n\
114                        set ${option} \[concat \$\{$option\} \$args\] \n\
115                    \} else \{ \n\
116                        set ${option} \$args \n\
117                    \} \n\
118                \} \n\
119        \}"
120    }
121}
122
123proc options_export {args} {
124    foreach option $args {
125        eval "proc options::export-${option} \{args\} \{ \n\
126            global ${option} PortInfo \n\
127            if \{\[info exists ${option}\]\} \{ \n\
128                set PortInfo(${option}) \$\{${option}\} \n\
129            \} else \{ \n\
130                unset PortInfo(${option}) \n\
131            \} \n\
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        eval "proc warn_deprecated_$option \{option action args\} \{ \n\
144            global portname $option $newoption \n\
145            if \{\$action != \"read\"\} \{ \n\
146                $newoption \$$option \n\
147            \} else \{ \n\
148                ui_warn \"Port \$portname using deprecated option \\\"$option\\\".\" \n\
149                $option \[set $newoption\] \n\
150            \} \n\
151        \}"
152    } else {
153        eval "proc warn_deprecated_$option \{option action args\} \{ \n\
154            global portname $option $newoption \n\
155            ui_warn \"Port \$portname using deprecated option \\\"$option\\\".\" \n\
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                eval "$p $optionName set ${optionValue}" 
177            }
178            return
179        }
180        r {
181            foreach p $option_procs($optionName) {
182                eval "$p $optionName read"
183            }
184            return
185        }
186        u {
187            foreach p $option_procs($optionName) {
188                eval "$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 $key
433    if {[info exists $key]} {
434        if {[string equal -nocase [set $key] "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# filefindbypath
514# Provides searching of the standard path for included files
515proc filefindbypath {fname} {
516    global distpath filesdir workdir worksrcdir portpath
517   
518    if {[file readable $portpath/$fname]} {
519        return $portpath/$fname
520    } elseif {[file readable $portpath/$filesdir/$fname]} {
521        return $portpath/$filesdir/$fname
522    } elseif {[file readable $distpath/$fname]} {
523        return $distpath/$fname
524    }
525    return ""
526}
527
528# include
529# Source a file, looking for it along a standard search path.
530proc include {fname} {
531    set tgt [filefindbypath $fname]
532    if {[string length $tgt]} {
533        uplevel "source $tgt"
534    } else {
535        return -code error "Unable to find include file $fname"
536    }
537}
538
539# makeuserproc
540# This procedure re-writes the user-defined custom target to include
541# all the globals in its scope.  This is undeniably ugly, but I haven't
542# thought of any other way to do this.
543proc makeuserproc {name body} {
544    regsub -- "^\{(.*?)" $body "\{ \n foreach g \[info globals\] \{ \n global \$g \n \} \n \\1" body
545    eval "proc $name {} $body"
546}
547
548########### Internal Dependancy Manipulation Procedures ###########
549
550proc target_run {ditem} {
551    global target_state_fd portpath portname portversion portrevision portvariants ports_force variations workpath ports_trace PortInfo
552    set result 0
553    set skipped 0
554    set procedure [ditem_key $ditem procedure]
555    if {$procedure != ""} {
556        set name [ditem_key $ditem name]
557       
558        if {[ditem_contains $ditem init]} {
559            set result [catch {[ditem_key $ditem init] $name} errstr]
560        }
561       
562        if { ![info exists portvariants] } {
563                set portvariants ""
564                set vlist [lsort -ascii [array names variations]]
565
566                # Put together variants in the form +foo+bar for the registry
567                foreach v $vlist {
568                        if { ![string equal $v [option os.platform]] && ![string equal $v [option os.arch]] } {
569                                set portvariants "${portvariants}+${v}"
570                        }
571                }
572        }
573
574        if {$result == 0} {
575                # Skip the step if required and explain why through ui_debug.
576                # 1st case: the step was already done (as mentioned in the state file)
577                if {[check_statefile target $name $target_state_fd]} {
578                    ui_debug "Skipping completed $name ($portname)"
579                    set skipped 1
580                # 2nd case: the step is not to always be performed
581                # and this exact port/version/revision/variants is already installed
582                # and user didn't mention -f
583                # and portfile didn't change since installation.
584                } elseif {[ditem_key $ditem runtype] != "always"
585                        && [registry_exists $portname $portversion $portrevision $portvariants]
586                        && !([info exists ports_force] && $ports_force == "yes")} {
587                                               
588                        # Did the Portfile change since installation?
589                        set regref [registry_open $portname $portversion $portrevision $portvariants]
590                       
591                        set installdate [registry_prop_retr $regref date]
592                        if { $installdate != 0
593                                && $installdate < [file mtime ${portpath}/Portfile]} {
594                                ui_debug "Portfile changed since installation"
595                        } else {
596                                # Say we're skipping.
597                                set skipped 1
598                               
599                                ui_debug "Skipping $name ($portname) since this port is already installed"
600                        }
601                       
602                        # Something to close the registry entry may be called here, if it existed.
603                # 3rd case: the same port/version/revision/Variants is already active
604                # and user didn't mention -f
605                } elseif {$name == "com.apple.activate"
606                        && [registry_exists $portname $portversion $portrevision $portvariants]
607                        && !([info exists ports_force] && $ports_force == "yes")} {
608                       
609                        # Is port active?
610                        set regref [registry_open $portname $portversion $portrevision $portvariants]
611                       
612                        if { [registry_prop_retr $regref active] != 0 } {
613                                # Say we're skipping.
614                                set skipped 1
615                               
616                                ui_debug "Skipping $name ($portname) since this port is already active"
617                        }
618                       
619                }
620                       
621                # otherwise execute the task.
622                if {$skipped == 0} {
623                        set target [ditem_key $ditem provides]
624                        if {([info exists ports_trace]
625                                && $ports_trace == "yes"
626                                && $target != "clean")} {
627                                trace_start $workpath
628                        }
629
630                        # Execute pre-run procedure
631                        if {[ditem_contains $ditem prerun]} {
632                        set result [catch {[ditem_key $ditem prerun] $name} errstr]
633                        }
634                       
635                        if {$result == 0} {
636                        foreach pre [ditem_key $ditem pre] {
637                                ui_debug "Executing $pre"
638                                set result [catch {$pre $name} errstr]
639                                if {$result != 0} { break }
640                        }
641                        }
642                       
643                        if {$result == 0} {
644                        ui_debug "Executing $name ($portname)"
645                        set result [catch {$procedure $name} errstr]
646                        }
647                       
648                        if {$result == 0} {
649                        foreach post [ditem_key $ditem post] {
650                                ui_debug "Executing $post"
651                                set result [catch {$post $name} errstr]
652                                if {$result != 0} { break }
653                        }
654                        }
655                        # Execute post-run procedure
656                        if {[ditem_contains $ditem postrun] && $result == 0} {
657                        set postrun [ditem_key $ditem postrun]
658                        ui_debug "Executing $postrun"
659                        set result [catch {$postrun $name} errstr]
660                        }
661
662                        # Check dependencies & file creations outside workpath.
663                        if {([info exists ports_trace]
664                                && $ports_trace == "yes"
665                                && $target != "clean")} {
666                                set depends {}
667                                set deptypes {}
668                               
669                                # Determine deptypes to look for based on target
670                                switch $target {
671                                        configure       { set deptypes "depends_lib" }
672                                       
673                                        build           { set deptypes "depends_lib depends_build" }
674                                       
675                                        destroot        -
676                                        install         -
677                                        archive         -
678                                        pkg                     -
679                                        mpkg            -
680                                        rpmpackage      -
681                                        dpkg            -
682                                        ""                      { set deptypes "depends_lib depends_build depends_run" }
683                                }
684                               
685                                # Gather the dependencies for deptypes
686                                foreach deptype $deptypes {
687                                        # Add to the list of dependencies if the option exists and isn't empty.
688                                        if {[info exists PortInfo($deptype)] && $PortInfo($deptype) != ""} {
689                                                set depends [concat $depends $PortInfo($deptype)]
690                                        }
691                                }
692
693                                # Dependencies are in the form verb:[param:]port
694                                set depsPorts {}
695                                foreach depspec $depends {
696                                        # grab the portname portion of the depspec
697                                        set dep_portname [lindex [split $depspec :] end]
698                                        lappend depsPorts $dep_portname
699                                }
700                                trace_check_deps $target $depsPorts
701                               
702                                # Check files that were created.
703                                if {$target != "activate"
704                                        && $target != "archive"
705                                        && $target != "fetch"
706                                        && $target != "install"} {
707                                        trace_check_create
708                                }
709
710                                # End of trace.
711                                trace_stop
712                        }
713                }
714        }
715        if {$result == 0} {
716                # Only write to state file if:
717                # - we indeed performed this step.
718                # - this step is not to always be performed
719                # - this step must be written to file
720                if {$skipped == 0
721            && [ditem_key $ditem runtype] != "always"
722            && [ditem_key $ditem state] != "no"} {
723                write_statefile target $name $target_state_fd
724            }
725        } else {
726            ui_error "Target $name returned: $errstr"
727            set result 1
728        }
729       
730    } else {
731        ui_info "Warning: $name does not have a registered procedure"
732        set result 1
733    }
734   
735    return $result
736}
737
738proc eval_targets {target} {
739    global targets target_state_fd portname
740    set dlist $targets
741   
742    # Select the subset of targets under $target
743    if {$target != ""} {
744        set matches [dlist_search $dlist provides $target]
745       
746        if {[llength $matches] > 0} {
747            set dlist [dlist_append_dependents $dlist [lindex $matches 0] [list]]
748            # Special-case 'all'
749        } elseif {$target != "all"} {
750            ui_error "unknown target: $target"
751            return 1
752        }
753    }
754   
755    # Restore the state from a previous run.
756    set target_state_fd [open_statefile]
757   
758    set dlist [dlist_eval $dlist "" target_run]
759   
760    if {[llength $dlist] > 0} {
761        # somebody broke!
762        set errstring "Warning: the following items did not execute (for $portname):"
763        foreach ditem $dlist {
764            append errstring " [ditem_key $ditem name]"
765        }
766        ui_info $errstring
767        set result 1
768    } else {
769        set result 0
770    }
771   
772    close $target_state_fd
773    return $result
774}
775
776# open_statefile
777# open file to store name of completed targets
778proc open_statefile {args} {
779    global workpath worksymlink portname portpath ports_ignore_older
780   
781    if {![file isdirectory $workpath]} {
782        file mkdir $workpath
783    }
784    # flock Portfile
785    set statefile [file join $workpath .darwinports.${portname}.state]
786    if {[file exists $statefile]} {
787        if {![file writable $statefile]} {
788            return -code error "$statefile is not writable - check permission on port directory"
789        }
790        if {!([info exists ports_ignore_older] && $ports_ignore_older == "yes") && [file mtime $statefile] < [file mtime ${portpath}/Portfile]} {
791            ui_msg "Portfile changed since last build; discarding previous state."
792            #file delete $statefile
793            exec rm -rf [file join $workpath]
794            exec mkdir [file join $workpath]
795        }
796    }
797
798    # Create a symlink to the workpath for port authors
799    if {![file isdirectory $worksymlink]} {
800            exec ln -sf $workpath $worksymlink
801    }
802   
803    set fd [open $statefile a+]
804    if {[catch {flock $fd -exclusive -noblock} result]} {
805        if {"$result" == "EAGAIN"} {
806            ui_msg "Waiting for lock on $statefile"
807        } elseif {"$result" == "EOPNOTSUPP"} {
808            # Locking not supported, just return
809            return $fd
810        } else {
811            return -code error "$result obtaining lock on $statefile"
812        }
813    }
814    flock $fd -exclusive
815    return $fd
816}
817
818# check_statefile
819# Check completed/selected state of target/variant $name
820proc check_statefile {class name fd} {
821    global portpath workdir
822   
823    seek $fd 0
824    while {[gets $fd line] >= 0} {
825        if {$line == "$class: $name"} {
826            return 1
827        }
828    }
829    return 0
830}
831
832# write_statefile
833# Set target $name completed in the state file
834proc write_statefile {class name fd} {
835    if {[check_statefile $class $name $fd]} {
836        return 0
837    }
838    seek $fd 0 end
839    puts $fd "$class: $name"
840    flush $fd
841}
842
843# check_statefile_variants
844# Check that recorded selection of variants match the current selection
845proc check_statefile_variants {variations fd} {
846    upvar $variations upvariations
847   
848    seek $fd 0
849    while {[gets $fd line] >= 0} {
850        if {[regexp "variant: (.*)" $line match name]} {
851            set oldvariations([string range $name 1 end]) [string range $name 0 0]
852        }
853    }
854   
855    set mismatch 0
856    if {[array size oldvariations] > 0} {
857        if {[array size oldvariations] != [array size upvariations]} {
858            set mismatch 1
859        } else {
860            foreach key [array names upvariations *] {
861                if {![info exists oldvariations($key)] || $upvariations($key) != $oldvariations($key)} {
862                    set mismatch 1
863                    break
864                }
865            }
866        }
867    }
868   
869    return $mismatch
870}
871
872########### Port Variants ###########
873
874# Each variant which provides a subset of the requested variations
875# will be chosen.  Returns a list of the selected variants.
876proc choose_variants {dlist variations} {
877    upvar $variations upvariations
878   
879    set selected [list]
880   
881    foreach ditem $dlist {
882        # Enumerate through the provides, tallying the pros and cons.
883        set pros 0
884        set cons 0
885        set ignored 0
886        foreach flavor [ditem_key $ditem provides] {
887            if {[info exists upvariations($flavor)]} {
888                if {$upvariations($flavor) == "+"} {
889                    incr pros
890                } elseif {$upvariations($flavor) == "-"} {
891                    incr cons
892                }
893            } else {
894                incr ignored
895            }
896        }
897       
898        if {$cons > 0} { continue }
899       
900        if {$pros > 0 && $ignored == 0} {
901            lappend selected $ditem
902        }
903    }
904    return $selected
905}
906
907proc variant_run {ditem} {
908    set name [ditem_key $ditem name]
909    ui_debug "Executing variant $name provides [ditem_key $ditem provides]"
910   
911    # test for conflicting variants
912    foreach v [ditem_key $ditem conflicts] {
913        if {[variant_isset $v]} {
914            ui_error "Variant $name conflicts with $v"
915            return 1
916        }
917    }
918   
919    # execute proc with same name as variant.
920    if {[catch "variant-${name}" result]} {
921        global errorInfo
922        ui_debug "$errorInfo"
923        ui_error "Error executing $name: $result"
924        return 1
925    }
926    return 0
927}
928
929proc eval_variants {variations target} {
930    global all_variants ports_force PortInfo
931    set dlist $all_variants
932    set result 0
933    upvar $variations upvariations
934    set chosen [choose_variants $dlist upvariations]
935        set portname $PortInfo(name)
936
937        # Check to make sure the requested variations are available with this
938        # port, if one is not, warn the user and remove the variant from the
939        # array.
940        foreach key [array names upvariations *] {
941                if {![info exists PortInfo(variants)] || 
942                        [lsearch $PortInfo(variants) $key] == -1} {
943                        ui_debug "Requested variant $key is not provided by port $portname."
944                        array unset upvariations $key
945                }
946        }
947
948    # now that we've selected variants, change all provides [a b c] to [a-b-c]
949    # this will eliminate ambiguity between item a, b, and a-b while fulfilling requirments.
950    #foreach obj $dlist {
951    #    $obj set provides [list [join [$obj get provides] -]]
952    #}
953   
954    set newlist [list]
955    foreach variant $chosen {
956                set newlist [dlist_append_dependents $dlist $variant $newlist]
957    }
958   
959    set dlist [dlist_eval $newlist "" variant_run]
960    if {[llength $dlist] > 0} {
961                return 1
962    }
963   
964    # Make sure the variations match those stored in the statefile.
965    # If they don't match, print an error indicating a 'port clean'
966    # should be performed. 
967    # - Skip this test if the statefile is empty.
968    # - Skip this test if performing a clean.
969    # - Skip this test if ports_force was specified.
970   
971    if {$target != "clean" && 
972        !([info exists ports_force] && $ports_force == "yes")} {
973        set state_fd [open_statefile]
974       
975        if {[check_statefile_variants upvariations $state_fd]} {
976            ui_error "Requested variants do not match original selection.\nPlease perform 'port clean $portname' or specify the force option."
977            set result 1
978        } else {
979            # Write variations out to the statefile
980            foreach key [array names upvariations *] {
981                write_statefile variant $upvariations($key)$key $state_fd
982            }
983        }
984       
985        close $state_fd
986    }
987   
988    return $result
989}
990
991# Target class definition.
992
993# constructor for target object
994proc target_new {name procedure} {
995    global targets
996    set ditem [ditem_create]
997   
998    ditem_key $ditem name $name
999    ditem_key $ditem procedure $procedure
1000   
1001    lappend targets $ditem
1002   
1003    return $ditem
1004}
1005
1006proc target_provides {ditem args} {
1007    global targets
1008    # Register the pre-/post- hooks for use in Portfile.
1009    # Portfile syntax: pre-fetch { puts "hello world" }
1010    # User-code exceptions are caught and returned as a result of the target.
1011    # Thus if the user code breaks, dependent targets will not execute.
1012    foreach target $args {
1013        set origproc [ditem_key $ditem procedure]
1014        set ident [ditem_key $ditem name]
1015        if {[info commands $target] != ""} {
1016            ui_debug "$ident registered provides \'$target\', a pre-existing procedure. Target override will not be provided"
1017        } else {
1018            eval "proc $target {args} \{ \n\
1019                        variable proc_index \n\
1020                        set proc_index \[llength \[ditem_key $ditem proc\]\] \n\
1021                        ditem_key $ditem procedure proc-${ident}-${target}-\${proc_index}
1022                        eval \"proc proc-${ident}-${target}-\${proc_index} \{name\} \{ \n\
1023                                if \{\\\[catch userproc-${ident}-${target}-\${proc_index} result\\\]\} \{ \n\
1024                                        return -code error \\\$result \n\
1025                                \} else \{ \n\
1026                                        return 0 \n\
1027                                \} \n\
1028                        \}\" \n\
1029                        eval \"proc do-$target \{\} \{ $origproc $target\}\" \n\
1030                        makeuserproc userproc-${ident}-${target}-\${proc_index} \$args \n\
1031                \}"
1032        }
1033        eval "proc pre-$target {args} \{ \n\
1034                        variable proc_index \n\
1035                        set proc_index \[llength \[ditem_key $ditem pre\]\] \n\
1036                        ditem_append $ditem pre proc-pre-${ident}-${target}-\${proc_index}
1037                        eval \"proc proc-pre-${ident}-${target}-\${proc_index} \{name\} \{ \n\
1038                                if \{\\\[catch userproc-pre-${ident}-${target}-\${proc_index} result\\\]\} \{ \n\
1039                                        return -code error \\\$result \n\
1040                                \} else \{ \n\
1041                                        return 0 \n\
1042                                \} \n\
1043                        \}\" \n\
1044                        makeuserproc userproc-pre-${ident}-${target}-\${proc_index} \$args \n\
1045                \}"
1046        eval "proc post-$target {args} \{ \n\
1047                        variable proc_index \n\
1048                        set proc_index \[llength \[ditem_key $ditem post\]\] \n\
1049                        ditem_append $ditem post proc-post-${ident}-${target}-\${proc_index}
1050                        eval \"proc proc-post-${ident}-${target}-\${proc_index} \{name\} \{ \n\
1051                                if \{\\\[catch userproc-post-${ident}-${target}-\${proc_index} result\\\]\} \{ \n\
1052                                        return -code error \\\$result \n\
1053                                \} else \{ \n\
1054                                        return 0 \n\
1055                                \} \n\
1056                        \}\" \n\
1057                        makeuserproc userproc-post-${ident}-${target}-\${proc_index} \$args \n\
1058                \}"
1059    }
1060    eval "ditem_append $ditem provides $args"
1061}
1062
1063proc target_requires {ditem args} {
1064    eval "ditem_append $ditem requires $args"
1065}
1066
1067proc target_uses {ditem args} {
1068    eval "ditem_append $ditem uses $args"
1069}
1070
1071proc target_deplist {ditem args} {
1072    eval "ditem_append $ditem deplist $args"
1073}
1074
1075proc target_prerun {ditem args} {
1076    eval "ditem_append $ditem prerun $args"
1077}
1078
1079proc target_postrun {ditem args} {
1080    eval "ditem_append $ditem postrun $args"
1081}
1082
1083proc target_runtype {ditem args} {
1084    eval "ditem_append $ditem runtype $args"
1085}
1086
1087proc target_state {ditem args} {
1088    eval "ditem_append $ditem state $args"
1089}
1090
1091proc target_init {ditem args} {
1092    eval "ditem_append $ditem init $args"
1093}
1094
1095##### variant class #####
1096
1097# constructor for variant objects
1098proc variant_new {name} {
1099    set ditem [ditem_create]
1100    ditem_key $ditem name $name
1101    return $ditem
1102}
1103
1104proc handle_default_variants {option action args} {
1105    global variations
1106    switch -regex $action {
1107        set|append {
1108            foreach v $args {
1109                if {[regexp {([-+])([-A-Za-z0-9_]+)} $v whole val variant]} {
1110                    if {![info exists variations($variant)]} {
1111                        set variations($variant) $val
1112                    }
1113                }
1114            }
1115        }
1116        delete {
1117            # xxx
1118        }
1119    }
1120}
1121
1122
1123# builds the specified port (looked up in the index) to the specified target
1124# doesn't yet support options or variants...
1125# newworkpath defines the port's workpath - useful for when one port relies
1126# on the source, etc, of another
1127proc portexec_int {portname target {newworkpath ""}} {
1128    ui_debug "Executing $target ($portname)"
1129    set variations [list]
1130    if {$newworkpath == ""} {
1131        array set options [list]
1132    } else {
1133        set options(workpath) ${newworkpath}
1134    }
1135    # Escape regex special characters
1136    regsub -all "(\\(){1}|(\\)){1}|(\\{1}){1}|(\\+){1}|(\\{1}){1}|(\\{){1}|(\\}){1}|(\\^){1}|(\\$){1}|(\\.){1}|(\\\\){1}" $portname "\\\\&" search_string
1137   
1138    set res [dport_search ^$search_string\$]
1139    if {[llength $res] < 2} {
1140        ui_error "Dependency $portname not found"
1141        return -1
1142    }
1143   
1144    array set portinfo [lindex $res 1]
1145    set porturl $portinfo(porturl)
1146    if {[catch {set worker [dport_open $porturl [array get options] $variations]} result]} {
1147                global errorInfo
1148                ui_debug "$errorInfo"
1149        ui_error "Opening $portname $target failed: $result"
1150        return -1
1151    }
1152    if {[catch {dport_exec $worker $target} result] || $result != 0} {
1153                global errorInfo
1154                ui_debug "$errorInfo"
1155        ui_error "Execution $portname $target failed: $result"
1156        dport_close $worker
1157        return -1
1158    }
1159    dport_close $worker
1160   
1161    return 0
1162}
1163
1164# portfile primitive that calls portexec_int with newworkpath == ${workpath}
1165proc portexec {portname target} {
1166    global workpath
1167    return [portexec_int $portname $target $workpath]
1168}
1169
1170proc adduser {name args} {
1171    global os.platform
1172    set passwd {\*}
1173    set uid [nextuid]
1174    set gid [existsgroup nogroup]
1175    set realname ${name}
1176    set home /dev/null
1177    set shell /dev/null
1178   
1179    foreach arg $args {
1180        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
1181            regsub -all " " ${val} "\\ " val
1182            set $key $val
1183        }
1184    }
1185   
1186    if {[existsuser ${name}] != 0 || [existsuser ${uid}] != 0} {
1187        return
1188    }
1189   
1190    if {${os.platform} == "darwin"} {
1191        system "niutil -create . /users/${name}"
1192        system "niutil -createprop . /users/${name} name ${name}"
1193        system "niutil -createprop . /users/${name} passwd ${passwd}"
1194        system "niutil -createprop . /users/${name} uid ${uid}"
1195        system "niutil -createprop . /users/${name} gid ${gid}"
1196        system "niutil -createprop . /users/${name} realname ${realname}"
1197        system "niutil -createprop . /users/${name} home ${home}"
1198        system "niutil -createprop . /users/${name} shell ${shell}"
1199    } else {
1200        # XXX adduser is only available for darwin, add more support here
1201        ui_warn "WARNING: adduser is not implemented on ${os.platform}."
1202        ui_warn "The requested user was not created."
1203    }
1204}
1205
1206proc addgroup {name args} {
1207    global os.platform
1208    set gid [nextgid]
1209    set passwd {\*}
1210    set users ""
1211   
1212    foreach arg $args {
1213        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
1214            regsub -all " " ${val} "\\ " val
1215            set $key $val
1216        }
1217    }
1218   
1219    if {[existsgroup ${name}] != 0 || [existsgroup ${gid}] != 0} {
1220        return
1221    }
1222   
1223    if {${os.platform} == "darwin"} {
1224        system "niutil -create . /groups/${name}"
1225        system "niutil -createprop . /groups/${name} name ${name}"
1226        system "niutil -createprop . /groups/${name} gid ${gid}"
1227        system "niutil -createprop . /groups/${name} passwd ${passwd}"
1228        system "niutil -createprop . /groups/${name} users ${users}"
1229    } else {
1230        # XXX addgroup is only available for darwin, add more support here
1231        ui_warn "WARNING: addgroup is not implemented on ${os.platform}."
1232        ui_warn "The requested group was not created."
1233    }
1234}
1235
1236# proc to calculate size of a directory
1237# moved here from portpkg.tcl
1238proc dirSize {dir} {
1239    set size    0;
1240    foreach file [readdir $dir] {
1241        if {[file type [file join $dir $file]] == "link" } {
1242            continue
1243        }
1244        if {[file isdirectory [file join $dir $file]]} {
1245            incr size [dirSize [file join $dir $file]]
1246        } else {
1247            incr size [file size [file join $dir $file]];
1248        }
1249    }
1250    return $size;
1251}
1252
1253# check for a binary in the path
1254# returns an error code if it can not be found
1255proc binaryInPath {binary} {
1256    global env
1257    foreach dir [split $env(PATH) :] { 
1258        if {[file executable [file join $dir $binary]]} {
1259            return [file join $dir $binary]
1260        }
1261    }
1262   
1263    return -code error [format [msgcat::mc "Failed to locate '%s' in path: '%s'"] $binary $env(PATH)];
1264}
1265
1266# Set the UI prefix to something standard (so it can be grepped for in output)
1267proc set_ui_prefix {} {
1268        global UI_PREFIX env
1269        if {[info exists env(UI_PREFIX)]} {
1270                set UI_PREFIX $env(UI_PREFIX)
1271        } else {
1272                set UI_PREFIX "---> "
1273        }
1274}
1275
1276# Use a specified group/version.
1277proc PortGroup {group version} {
1278        global portresourcepath
1279
1280        set groupFile ${portresourcepath}/group/${group}-${version}.tcl
1281
1282        if {[file exists $groupFile]} {
1283                uplevel "source $groupFile"
1284        } else {
1285                ui_warn "Group file could not be located."
1286        }
1287}
1288
1289# check if archive type is supported by current system
1290# returns an error code if it is not
1291proc archiveTypeIsSupported {type} {
1292    global os.platform os.version
1293        set errmsg ""
1294        switch -regex $type {
1295                cp(io|gz) {
1296                        set pax "pax"
1297                        if {[catch {set pax [binaryInPath $pax]} errmsg] == 0} {
1298                                if {[regexp {z$} $type]} {
1299                                        set gzip "gzip"
1300                                        if {[catch {set gzip [binaryInPath $gzip]} errmsg] == 0} {
1301                                                return 0
1302                                        }
1303                                } else {
1304                                        return 0
1305                                }
1306                        }
1307                }
1308                t(ar|bz|gz) {
1309                        set tar "tar"
1310                        if {[catch {set tar [binaryInPath $tar]} errmsg] == 0} {
1311                                if {[regexp {z$} $type]} {
1312                                        if {[regexp {bz$} $type]} {
1313                                                set gzip "bzip2"
1314                                        } else {
1315                                                set gzip "gzip"
1316                                        }
1317                                        if {[catch {set gzip [binaryInPath $gzip]} errmsg] == 0} {
1318                                                return 0
1319                                        }
1320                                } else {
1321                                        return 0
1322                                }
1323                        }
1324                }
1325                xar {
1326                        set xar "xar"
1327                        if {[catch {set xar [binaryInPath $xar]} errmsg] == 0} {
1328                                return 0
1329                        }
1330                }
1331                zip {
1332                        set zip "zip"
1333                        if {[catch {set zip [binaryInPath $zip]} errmsg] == 0} {
1334                                set unzip "unzip"
1335                                if {[catch {set unzip [binaryInPath $unzip]} errmsg] == 0} {
1336                                        return 0
1337                                }
1338                        }
1339                }
1340                default {
1341                        return -code error [format [msgcat::mc "Invalid port archive type '%s' specified!"] $type]
1342                }
1343        }
1344        return -code error [format [msgcat::mc "Unsupported port archive type '%s': %s"] $type $errmsg]
1345}
1346
Note: See TracBrowser for help on using the repository browser.