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

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

Revert my change to tbool - it turns out this interferes with read traces on the variable (which is stupid - the trace should be smart enough to remember the original name).

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 45.1 KB
Line 
1# et:ts=4
2# portutil.tcl
3# $Id: portutil.tcl 22023 2007-02-14 19:22:00Z 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    ui_debug "tbool: $key"
433    upvar $key $key
434    if {[info exists $key]} {
435        if {[string equal -nocase [set $key] "yes"]} {
436            return 1
437        }
438    }
439    return 0
440}
441
442# ldelete
443# Deletes a value from the supplied list
444proc ldelete {list value} {
445    set ix [lsearch -exact $list $value]
446    if {$ix >= 0} {
447        return [lreplace $list $ix $ix]
448    }
449    return $list
450}
451
452# reinplace
453# Provides "sed in place" functionality
454proc reinplace {pattern args}  {
455    if {$args == ""} {
456        ui_error "reinplace: no value given for parameter \"file\""
457        return -code error "no value given for parameter \"file\" to \"reinplace\"" 
458    }
459   
460    foreach file $args {
461        if {[catch {set tmpfile [mkstemp "/tmp/[file tail $file].sed.XXXXXXXX"]} error]} {
462                global errorInfo
463                ui_debug "$errorInfo"
464            ui_error "reinplace: $error"
465            return -code error "reinplace failed"
466        } else {
467            # Extract the Tcl Channel number
468            set tmpfd [lindex $tmpfile 0]
469            # Set tmpfile to only the file name
470            set tmpfile [lindex $tmpfile 1]
471        }
472       
473        if {[catch {exec sed $pattern < $file >@ $tmpfd} error]} {
474                global errorInfo
475                ui_debug "$errorInfo"
476            ui_error "reinplace: $error"
477            file delete "$tmpfile"
478            close $tmpfd
479            return -code error "reinplace sed(1) failed"
480        }
481       
482        close $tmpfd
483       
484        set attributes [file attributes $file]
485        # We need to overwrite this file
486        if {[catch {file attributes $file -permissions u+w} error]} {
487                global errorInfo
488                ui_debug "$errorInfo"
489            ui_error "reinplace: $error"
490            file delete "$tmpfile"
491            return -code error "reinplace permissions failed"
492        }
493       
494        if {[catch {exec cp $tmpfile $file} error]} {
495                global errorInfo
496                ui_debug "$errorInfo"
497            ui_error "reinplace: $error"
498            file delete "$tmpfile"
499            return -code error "reinplace copy failed"
500        }
501       
502        for {set i 0} {$i < [llength attributes]} {incr i} {
503            set opt [lindex $attributes $i]
504            incr i
505            set arg [lindex $attributes $i]
506            file attributes $file $opt $arg
507        }
508       
509        file delete "$tmpfile"
510    }
511    return
512}
513
514# delete
515# file delete -force by itself doesn't handle directories properly
516# on systems older than Tiger. However we can recurse this thing ourselves
517proc delete {args} {
518    foreach arg $args {
519        ui_debug "delete: $arg"
520        set stack [list $arg]
521        while {[llength $stack] > 0} {
522            set file [lindex $stack 0]
523            if {[string equal [file type $file] directory]} {
524                # it's a directory
525                set children [glob -nocomplain -directory $file * .*]
526                set children [ldelete [ldelete $children $file/.] $file/..]
527                if {[llength $children] > 0} {
528                    set stack [concat $children $stack]
529                } else {
530                    # directory is empty
531                    file delete -force -- $file
532                    set stack [lrange $stack 1 end]
533                }
534            } else {
535                # it's not a directory - kill it now
536                file delete -force -- $file
537                set stack [lrange $stack 1 end]
538            }
539        }
540    }
541}
542
543# touch
544# mimics the BSD touch command
545proc touch {args} {
546    while {[string match -* [lindex $args 0]]} {
547        set arg [string range [lindex $args 0] 1 end]
548        set args [lrange $args 1 end]
549        switch -- $arg {
550            a -
551            c -
552            m {set options($arg) yes}
553            r -
554            t {
555                set narg [lindex $args 0]
556                set args [lrange $args 1 end]
557                if {[string length $narg] == 0} {
558                    return -code error "touch: option requires an argument -- $arg"
559                }
560                set options($arg) $narg
561                set options(rt) $arg ;# later option overrides earlier
562            }
563            - break
564            default {return -code error "touch: illegal option -- $arg"}
565        }
566    }
567   
568    # parse the r/t options
569    if {[info exists options(rt)]} {
570        if {[string equal $options(rt) r]} {
571            # -r
572            # get atime/mtime from the file
573            if {[file exists $options(r)]} {
574                set atime [file atime $options(r)]
575                set mtime [file mtime $options(r)]
576            } else {
577                return -code error "touch: $options(r): No such file or directory"
578            }
579        } else {
580            # -t
581            # parse the time specification
582            # turn it into a CCyymmdd hhmmss
583            set timespec {^(?:(\d\d)?(\d\d))?(\d\d)(\d\d)(\d\d)(\d\d)(?:\.(\d\d))?$}
584            if {[regexp $timespec $options(t) {} CC YY MM DD hh mm SS]} {
585                if {[string length $YY] == 0} {
586                    set year [clock format [clock seconds] -format %Y]
587                } elseif {[string length $CC] == 0} {
588                    if {$YY >= 69 && $YY <= 99} {
589                        set year 19$YY
590                    } else {
591                        set year 20$YY
592                    }
593                } else {
594                    set year $CC$YY
595                }
596                if {[string length $SS] == 0} {
597                    set SS 00
598                }
599                set atime [clock scan "$year$MM$DD $hh$mm$SS"]
600                set mtime $atime
601            } else {
602                return -code error \
603                    {touch: out of range or illegal time specification: [[CC]YY]MMDDhhmm[.SS]}
604            }
605        }
606    } else {
607        set atime [clock seconds]
608        set mtime [clock seconds]
609    }
610   
611    # do we have any files to process?
612    if {[llength $args] == 0} {
613        # print usage
614        ui_msg {usage: touch [-a] [-c] [-m] [-r file] [-t [[CC]YY]MMDDhhmm[.SS]] file ...}
615        return
616    }
617   
618    foreach file $args {
619        if {![file exists $file]} {
620            if {[info exists options(c)]} {
621                continue
622            } else {
623                close [open $file w]
624            }
625        }
626       
627        if {[info exists options(a)] || ![info exists options(m)]} {
628            file atime $file $atime
629        }
630        if {[info exists options(m)] || ![info exists options(a)]} {
631            file mtime $file $mtime
632        }
633    }
634    return
635}
636
637# copy
638proc copy {args} {
639    exec file copy $args
640}
641
642# move
643proc move {args} {
644    exec file rename $args
645}
646
647# ln
648# Mimics the BSD ln implementation
649# ln [-f] [-h] [-s] [-v] source_file [target_file]
650# ln [-f] [-h] [-s] [-v] source_file ... target_dir
651proc ln {args} {
652    while {[string match -* [lindex $args 0]]} {
653        set arg [string range [lindex $args 0] 1 end]
654        set args [lrange $args 1 end]
655        switch -- $arg {
656            f -
657            h -
658            s -
659            v {set options($arg) yes}
660            - break
661            default {return -code error "ln: illegal option -- $arg"}
662        }
663    }
664   
665    if {[llength $args] == 0} {
666        ui_msg {usage: ln [-f] [-h] [-s] [-v] source_file [target_file]}
667        ui_msg {       ln [-f] [-h] [-s] [-v] file ... directory}
668        return
669    } elseif {[llength $args] == 1} {
670        set files $args
671        set target ./
672    } else {
673        set files [lrange $args 0 [expr [llength $args] - 2]]
674        set target [lindex $args end]
675    }
676   
677    foreach file $files {
678        if {[file isdirectory $file] && ![info exists options(s)]} {
679            return -code error "ln: $file: Is a directory"
680        }
681       
682        if {[file isdirectory $target] && ![info exists options(h)]} {
683            set linktarget [file join $target [file tail $file]]
684        } else {
685            set linktarget $target
686        }
687       
688        if {[file exists $linktarget] && ![info exists options(f)]} {
689            return -code error "ln: $linktarget: File exists"
690        }
691       
692        if {[llength $files] > 2} {
693            if {![file exists $linktarget]} {
694                return -code error "ln: $linktarget: No such file or directory"
695            } elseif {![file isdirectory $target]} {
696                # this error isn't striclty what BSD ln gives, but I think it's more useful
697                return -code error "ln: $target: Not a directory"
698            }
699        }
700       
701        if {[info exists options(v)]} {
702            ui_msg "ln: $linktarget -> $file"
703        }
704        if {[info exists options(s)]} {
705            file link -symbolic $linktarget $file
706        } else {
707            file link -hard $linktarget $file
708        }
709    }
710    return
711}
712
713# filefindbypath
714# Provides searching of the standard path for included files
715proc filefindbypath {fname} {
716    global distpath filesdir workdir worksrcdir portpath
717   
718    if {[file readable $portpath/$fname]} {
719        return $portpath/$fname
720    } elseif {[file readable $portpath/$filesdir/$fname]} {
721        return $portpath/$filesdir/$fname
722    } elseif {[file readable $distpath/$fname]} {
723        return $distpath/$fname
724    }
725    return ""
726}
727
728# include
729# Source a file, looking for it along a standard search path.
730proc include {fname} {
731    set tgt [filefindbypath $fname]
732    if {[string length $tgt]} {
733        uplevel "source $tgt"
734    } else {
735        return -code error "Unable to find include file $fname"
736    }
737}
738
739# makeuserproc
740# This procedure re-writes the user-defined custom target to include
741# all the globals in its scope.  This is undeniably ugly, but I haven't
742# thought of any other way to do this.
743proc makeuserproc {name body} {
744    regsub -- "^\{(.*?)" $body "\{ \n foreach g \[info globals\] \{ \n global \$g \n \} \n \\1" body
745    eval "proc $name {} $body"
746}
747
748########### Internal Dependancy Manipulation Procedures ###########
749
750proc target_run {ditem} {
751    global target_state_fd portpath portname portversion portrevision portvariants ports_force variations workpath ports_trace PortInfo
752    set result 0
753    set skipped 0
754    set procedure [ditem_key $ditem procedure]
755    if {$procedure != ""} {
756        set name [ditem_key $ditem name]
757       
758        if {[ditem_contains $ditem init]} {
759            set result [catch {[ditem_key $ditem init] $name} errstr]
760        }
761       
762        if { ![info exists portvariants] } {
763                set portvariants ""
764                set vlist [lsort -ascii [array names variations]]
765
766                # Put together variants in the form +foo+bar for the registry
767                foreach v $vlist {
768                        if { ![string equal $v [option os.platform]] && ![string equal $v [option os.arch]] } {
769                                set portvariants "${portvariants}+${v}"
770                        }
771                }
772        }
773
774        if {$result == 0} {
775                # Skip the step if required and explain why through ui_debug.
776                # 1st case: the step was already done (as mentioned in the state file)
777                if {[check_statefile target $name $target_state_fd]} {
778                    ui_debug "Skipping completed $name ($portname)"
779                    set skipped 1
780                # 2nd case: the step is not to always be performed
781                # and this exact port/version/revision/variants is already installed
782                # and user didn't mention -f
783                # and portfile didn't change since installation.
784                } elseif {[ditem_key $ditem runtype] != "always"
785                        && [registry_exists $portname $portversion $portrevision $portvariants]
786                        && !([info exists ports_force] && $ports_force == "yes")} {
787                                               
788                        # Did the Portfile change since installation?
789                        set regref [registry_open $portname $portversion $portrevision $portvariants]
790                       
791                        set installdate [registry_prop_retr $regref date]
792                        if { $installdate != 0
793                                && $installdate < [file mtime ${portpath}/Portfile]} {
794                                ui_debug "Portfile changed since installation"
795                        } else {
796                                # Say we're skipping.
797                                set skipped 1
798                               
799                                ui_debug "Skipping $name ($portname) since this port is already installed"
800                        }
801                       
802                        # Something to close the registry entry may be called here, if it existed.
803                # 3rd case: the same port/version/revision/Variants is already active
804                # and user didn't mention -f
805                } elseif {$name == "com.apple.activate"
806                        && [registry_exists $portname $portversion $portrevision $portvariants]
807                        && !([info exists ports_force] && $ports_force == "yes")} {
808                       
809                        # Is port active?
810                        set regref [registry_open $portname $portversion $portrevision $portvariants]
811                       
812                        if { [registry_prop_retr $regref active] != 0 } {
813                                # Say we're skipping.
814                                set skipped 1
815                               
816                                ui_debug "Skipping $name ($portname) since this port is already active"
817                        }
818                       
819                }
820                       
821                # otherwise execute the task.
822                if {$skipped == 0} {
823                        set target [ditem_key $ditem provides]
824                        if {([info exists ports_trace]
825                                && $ports_trace == "yes"
826                                && $target != "clean")} {
827                                trace_start $workpath
828
829                                # Enable the fence to prevent any creation/modification
830                                # outside the sandbox.
831                                if {$target != "activate"
832                                        && $target != "archive"
833                                        && $target != "fetch"
834                                        && $target != "install"} {
835                                        trace_enable_fence
836                                }
837                        }
838
839                        # Execute pre-run procedure
840                        if {[ditem_contains $ditem prerun]} {
841                        set result [catch {[ditem_key $ditem prerun] $name} errstr]
842                        }
843                       
844                        if {$result == 0} {
845                        foreach pre [ditem_key $ditem pre] {
846                                ui_debug "Executing $pre"
847                                set result [catch {$pre $name} errstr]
848                                if {$result != 0} { break }
849                        }
850                        }
851                       
852                        if {$result == 0} {
853                        ui_debug "Executing $name ($portname)"
854                        set result [catch {$procedure $name} errstr]
855                        }
856                       
857                        if {$result == 0} {
858                        foreach post [ditem_key $ditem post] {
859                                ui_debug "Executing $post"
860                                set result [catch {$post $name} errstr]
861                                if {$result != 0} { break }
862                        }
863                        }
864                        # Execute post-run procedure
865                        if {[ditem_contains $ditem postrun] && $result == 0} {
866                        set postrun [ditem_key $ditem postrun]
867                        ui_debug "Executing $postrun"
868                        set result [catch {$postrun $name} errstr]
869                        }
870
871                        # Check dependencies & file creations outside workpath.
872                        if {[info exists ports_trace]
873                                && $ports_trace == "yes"
874                                && $target != "clean"} {
875                               
876                                # Don't check dependencies for extract (they're not honored
877                                # anyway). This avoids warnings about bzip2.
878                                if {$target != "extract"} {
879                                        set depends {}
880                                        set deptypes {}
881                                       
882                                        # Determine deptypes to look for based on target
883                                        switch $target {
884                                                configure       { set deptypes "depends_lib" }
885                                               
886                                                build           { set deptypes "depends_lib depends_build" }
887                                               
888                                                destroot        -
889                                                install         -
890                                                archive         -
891                                                pkg                     -
892                                                mpkg            -
893                                                rpmpackage      -
894                                                dpkg            -
895                                                ""                      { set deptypes "depends_lib depends_build depends_run" }
896                                        }
897                                       
898                                        # Gather the dependencies for deptypes
899                                        foreach deptype $deptypes {
900                                                # Add to the list of dependencies if the option exists and isn't empty.
901                                                if {[info exists PortInfo($deptype)] && $PortInfo($deptype) != ""} {
902                                                        set depends [concat $depends $PortInfo($deptype)]
903                                                }
904                                        }
905       
906                                        # Dependencies are in the form verb:[param:]port
907                                        set depsPorts {}
908                                        foreach depspec $depends {
909                                                # grab the portname portion of the depspec
910                                                set dep_portname [lindex [split $depspec :] end]
911                                                lappend depsPorts $dep_portname
912                                        }
913                                        trace_check_deps $target $depsPorts
914                                }
915                               
916                                trace_check_violations
917                               
918                                # End of trace.
919                                trace_stop
920                        }
921                }
922        }
923        if {$result == 0} {
924                # Only write to state file if:
925                # - we indeed performed this step.
926                # - this step is not to always be performed
927                # - this step must be written to file
928                if {$skipped == 0
929            && [ditem_key $ditem runtype] != "always"
930            && [ditem_key $ditem state] != "no"} {
931                write_statefile target $name $target_state_fd
932            }
933        } else {
934            ui_error "Target $name returned: $errstr"
935            set result 1
936        }
937       
938    } else {
939        ui_info "Warning: $name does not have a registered procedure"
940        set result 1
941    }
942   
943    return $result
944}
945
946proc eval_targets {target} {
947    global targets target_state_fd portname
948    set dlist $targets
949   
950    # Select the subset of targets under $target
951    if {$target != ""} {
952        set matches [dlist_search $dlist provides $target]
953       
954        if {[llength $matches] > 0} {
955            set dlist [dlist_append_dependents $dlist [lindex $matches 0] [list]]
956            # Special-case 'all'
957        } elseif {$target != "all"} {
958            ui_error "unknown target: $target"
959            return 1
960        }
961    }
962   
963    # Restore the state from a previous run.
964    set target_state_fd [open_statefile]
965   
966    set dlist [dlist_eval $dlist "" target_run]
967   
968    if {[llength $dlist] > 0} {
969        # somebody broke!
970        set errstring "Warning: the following items did not execute (for $portname):"
971        foreach ditem $dlist {
972            append errstring " [ditem_key $ditem name]"
973        }
974        ui_info $errstring
975        set result 1
976    } else {
977        set result 0
978    }
979   
980    close $target_state_fd
981    return $result
982}
983
984# open_statefile
985# open file to store name of completed targets
986proc open_statefile {args} {
987    global workpath worksymlink portname portpath ports_ignore_older
988   
989    if {![file isdirectory $workpath]} {
990        file mkdir $workpath
991    }
992    # flock Portfile
993    set statefile [file join $workpath .darwinports.${portname}.state]
994    if {[file exists $statefile]} {
995        if {![file writable $statefile]} {
996            return -code error "$statefile is not writable - check permission on port directory"
997        }
998        if {!([info exists ports_ignore_older] && $ports_ignore_older == "yes") && [file mtime $statefile] < [file mtime ${portpath}/Portfile]} {
999            ui_msg "Portfile changed since last build; discarding previous state."
1000            #file delete $statefile
1001            exec rm -rf [file join $workpath]
1002            exec mkdir [file join $workpath]
1003        }
1004    }
1005
1006    # Create a symlink to the workpath for port authors
1007    if {![file isdirectory $worksymlink]} {
1008            exec ln -sf $workpath $worksymlink
1009    }
1010   
1011    set fd [open $statefile a+]
1012    if {[catch {flock $fd -exclusive -noblock} result]} {
1013        if {"$result" == "EAGAIN"} {
1014            ui_msg "Waiting for lock on $statefile"
1015        } elseif {"$result" == "EOPNOTSUPP"} {
1016            # Locking not supported, just return
1017            return $fd
1018        } else {
1019            return -code error "$result obtaining lock on $statefile"
1020        }
1021    }
1022    flock $fd -exclusive
1023    return $fd
1024}
1025
1026# check_statefile
1027# Check completed/selected state of target/variant $name
1028proc check_statefile {class name fd} {
1029    global portpath workdir
1030   
1031    seek $fd 0
1032    while {[gets $fd line] >= 0} {
1033        if {$line == "$class: $name"} {
1034            return 1
1035        }
1036    }
1037    return 0
1038}
1039
1040# write_statefile
1041# Set target $name completed in the state file
1042proc write_statefile {class name fd} {
1043    if {[check_statefile $class $name $fd]} {
1044        return 0
1045    }
1046    seek $fd 0 end
1047    puts $fd "$class: $name"
1048    flush $fd
1049}
1050
1051# check_statefile_variants
1052# Check that recorded selection of variants match the current selection
1053proc check_statefile_variants {variations fd} {
1054    upvar $variations upvariations
1055   
1056    seek $fd 0
1057    while {[gets $fd line] >= 0} {
1058        if {[regexp "variant: (.*)" $line match name]} {
1059            set oldvariations([string range $name 1 end]) [string range $name 0 0]
1060        }
1061    }
1062   
1063    set mismatch 0
1064    if {[array size oldvariations] > 0} {
1065        if {[array size oldvariations] != [array size upvariations]} {
1066            set mismatch 1
1067        } else {
1068            foreach key [array names upvariations *] {
1069                if {![info exists oldvariations($key)] || $upvariations($key) != $oldvariations($key)} {
1070                    set mismatch 1
1071                    break
1072                }
1073            }
1074        }
1075    }
1076   
1077    return $mismatch
1078}
1079
1080########### Port Variants ###########
1081
1082# Each variant which provides a subset of the requested variations
1083# will be chosen.  Returns a list of the selected variants.
1084proc choose_variants {dlist variations} {
1085    upvar $variations upvariations
1086   
1087    set selected [list]
1088   
1089    foreach ditem $dlist {
1090        # Enumerate through the provides, tallying the pros and cons.
1091        set pros 0
1092        set cons 0
1093        set ignored 0
1094        foreach flavor [ditem_key $ditem provides] {
1095            if {[info exists upvariations($flavor)]} {
1096                if {$upvariations($flavor) == "+"} {
1097                    incr pros
1098                } elseif {$upvariations($flavor) == "-"} {
1099                    incr cons
1100                }
1101            } else {
1102                incr ignored
1103            }
1104        }
1105       
1106        if {$cons > 0} { continue }
1107       
1108        if {$pros > 0 && $ignored == 0} {
1109            lappend selected $ditem
1110        }
1111    }
1112    return $selected
1113}
1114
1115proc variant_run {ditem} {
1116    set name [ditem_key $ditem name]
1117    ui_debug "Executing variant $name provides [ditem_key $ditem provides]"
1118   
1119    # test for conflicting variants
1120    foreach v [ditem_key $ditem conflicts] {
1121        if {[variant_isset $v]} {
1122            ui_error "Variant $name conflicts with $v"
1123            return 1
1124        }
1125    }
1126   
1127    # execute proc with same name as variant.
1128    if {[catch "variant-${name}" result]} {
1129        global errorInfo
1130        ui_debug "$errorInfo"
1131        ui_error "Error executing $name: $result"
1132        return 1
1133    }
1134    return 0
1135}
1136
1137proc eval_variants {variations target} {
1138    global all_variants ports_force PortInfo
1139    set dlist $all_variants
1140    set result 0
1141    upvar $variations upvariations
1142    set chosen [choose_variants $dlist upvariations]
1143        set portname $PortInfo(name)
1144
1145        # Check to make sure the requested variations are available with this
1146        # port, if one is not, warn the user and remove the variant from the
1147        # array.
1148        foreach key [array names upvariations *] {
1149                if {![info exists PortInfo(variants)] || 
1150                        [lsearch $PortInfo(variants) $key] == -1} {
1151                        ui_debug "Requested variant $key is not provided by port $portname."
1152                        array unset upvariations $key
1153                }
1154        }
1155
1156    # now that we've selected variants, change all provides [a b c] to [a-b-c]
1157    # this will eliminate ambiguity between item a, b, and a-b while fulfilling requirments.
1158    #foreach obj $dlist {
1159    #    $obj set provides [list [join [$obj get provides] -]]
1160    #}
1161   
1162    set newlist [list]
1163    foreach variant $chosen {
1164                set newlist [dlist_append_dependents $dlist $variant $newlist]
1165    }
1166   
1167    set dlist [dlist_eval $newlist "" variant_run]
1168    if {[llength $dlist] > 0} {
1169                return 1
1170    }
1171   
1172    # Make sure the variations match those stored in the statefile.
1173    # If they don't match, print an error indicating a 'port clean'
1174    # should be performed. 
1175    # - Skip this test if the statefile is empty.
1176    # - Skip this test if performing a clean.
1177    # - Skip this test if ports_force was specified.
1178   
1179    if {$target != "clean" && 
1180        !([info exists ports_force] && $ports_force == "yes")} {
1181        set state_fd [open_statefile]
1182       
1183        if {[check_statefile_variants upvariations $state_fd]} {
1184            ui_error "Requested variants do not match original selection.\nPlease perform 'port clean $portname' or specify the force option."
1185            set result 1
1186        } else {
1187            # Write variations out to the statefile
1188            foreach key [array names upvariations *] {
1189                write_statefile variant $upvariations($key)$key $state_fd
1190            }
1191        }
1192       
1193        close $state_fd
1194    }
1195   
1196    return $result
1197}
1198
1199# Target class definition.
1200
1201# constructor for target object
1202proc target_new {name procedure} {
1203    global targets
1204    set ditem [ditem_create]
1205   
1206    ditem_key $ditem name $name
1207    ditem_key $ditem procedure $procedure
1208   
1209    lappend targets $ditem
1210   
1211    return $ditem
1212}
1213
1214proc target_provides {ditem args} {
1215    global targets
1216    # Register the pre-/post- hooks for use in Portfile.
1217    # Portfile syntax: pre-fetch { puts "hello world" }
1218    # User-code exceptions are caught and returned as a result of the target.
1219    # Thus if the user code breaks, dependent targets will not execute.
1220    foreach target $args {
1221        set origproc [ditem_key $ditem procedure]
1222        set ident [ditem_key $ditem name]
1223        if {[info commands $target] != ""} {
1224            ui_debug "$ident registered provides '$target', a pre-existing procedure. Target override will not be provided"
1225        } else {
1226            proc $target {args} "
1227                variable proc_index
1228                set proc_index \[llength \[ditem_key $ditem proc\]\]
1229                ditem_key $ditem procedure proc-${ident}-${target}-\${proc_index}
1230                proc proc-${ident}-${target}-\${proc_index} {name} \"
1231                    if {\\\[catch userproc-${ident}-${target}-\${proc_index} result\\\]} {
1232                        return -code error \\\$result
1233                    } else {
1234                        return 0
1235                    }
1236                \"
1237                proc do-$target {} { $origproc $target }
1238                makeuserproc userproc-${ident}-${target}-\${proc_index} \$args
1239            "
1240        }
1241        proc pre-$target {args} "
1242            variable proc_index
1243            set proc_index \[llength \[ditem_key $ditem pre\]\]
1244            ditem_append $ditem pre proc-pre-${ident}-${target}-\${proc_index}
1245            proc proc-pre-${ident}-${target}-\${proc_index} {name} \"
1246                if {\\\[catch userproc-pre-${ident}-${target}-\${proc_index} result\\\]} {
1247                    return -code error \\\$result
1248                } else {
1249                    return 0
1250                }
1251            \"
1252            makeuserproc userproc-pre-${ident}-${target}-\${proc_index} \$args
1253        "
1254        proc post-$target {args} "
1255            variable proc_index
1256            set proc_index \[llength \[ditem_key $ditem post\]\]
1257            ditem_append $ditem post proc-post-${ident}-${target}-\${proc_index}
1258            proc proc-post-${ident}-${target}-\${proc_index} {name} \"
1259                if {\\\[catch userproc-post-${ident}-${target}-\${proc_index} result\\\]} {
1260                    return -code error \\\$result
1261                } else {
1262                    return 0
1263                }
1264            \"
1265            makeuserproc userproc-post-${ident}-${target}-\${proc_index} \$args
1266        "
1267    }
1268    eval ditem_append $ditem provides $args
1269}
1270
1271proc target_requires {ditem args} {
1272    eval ditem_append $ditem requires $args
1273}
1274
1275proc target_uses {ditem args} {
1276    eval ditem_append $ditem uses $args
1277}
1278
1279proc target_deplist {ditem args} {
1280    eval ditem_append $ditem deplist $args
1281}
1282
1283proc target_prerun {ditem args} {
1284    eval ditem_append $ditem prerun $args
1285}
1286
1287proc target_postrun {ditem args} {
1288    eval ditem_append $ditem postrun $args
1289}
1290
1291proc target_runtype {ditem args} {
1292    eval ditem_append $ditem runtype $args
1293}
1294
1295proc target_state {ditem args} {
1296    eval ditem_append $ditem state $args
1297}
1298
1299proc target_init {ditem args} {
1300    eval ditem_append $ditem init $args
1301}
1302
1303##### variant class #####
1304
1305# constructor for variant objects
1306proc variant_new {name} {
1307    set ditem [ditem_create]
1308    ditem_key $ditem name $name
1309    return $ditem
1310}
1311
1312proc handle_default_variants {option action args} {
1313    global variations
1314    switch -regex $action {
1315        set|append {
1316            foreach v $args {
1317                if {[regexp {([-+])([-A-Za-z0-9_]+)} $v whole val variant]} {
1318                    if {![info exists variations($variant)]} {
1319                        set variations($variant) $val
1320                    }
1321                }
1322            }
1323        }
1324        delete {
1325            # xxx
1326        }
1327    }
1328}
1329
1330
1331# builds the specified port (looked up in the index) to the specified target
1332# doesn't yet support options or variants...
1333# newworkpath defines the port's workpath - useful for when one port relies
1334# on the source, etc, of another
1335proc portexec_int {portname target {newworkpath ""}} {
1336    ui_debug "Executing $target ($portname)"
1337    set variations [list]
1338    if {$newworkpath == ""} {
1339        array set options [list]
1340    } else {
1341        set options(workpath) ${newworkpath}
1342    }
1343    # Escape regex special characters
1344    regsub -all "(\\(){1}|(\\)){1}|(\\{1}){1}|(\\+){1}|(\\{1}){1}|(\\{){1}|(\\}){1}|(\\^){1}|(\\$){1}|(\\.){1}|(\\\\){1}" $portname "\\\\&" search_string
1345   
1346    set res [dport_search ^$search_string\$]
1347    if {[llength $res] < 2} {
1348        ui_error "Dependency $portname not found"
1349        return -1
1350    }
1351   
1352    array set portinfo [lindex $res 1]
1353    set porturl $portinfo(porturl)
1354    if {[catch {set worker [dport_open $porturl [array get options] $variations]} result]} {
1355                global errorInfo
1356                ui_debug "$errorInfo"
1357        ui_error "Opening $portname $target failed: $result"
1358        return -1
1359    }
1360    if {[catch {dport_exec $worker $target} result] || $result != 0} {
1361                global errorInfo
1362                ui_debug "$errorInfo"
1363        ui_error "Execution $portname $target failed: $result"
1364        dport_close $worker
1365        return -1
1366    }
1367    dport_close $worker
1368   
1369    return 0
1370}
1371
1372# portfile primitive that calls portexec_int with newworkpath == ${workpath}
1373proc portexec {portname target} {
1374    global workpath
1375    return [portexec_int $portname $target $workpath]
1376}
1377
1378proc adduser {name args} {
1379    global os.platform
1380    set passwd {\*}
1381    set uid [nextuid]
1382    set gid [existsgroup nogroup]
1383    set realname ${name}
1384    set home /dev/null
1385    set shell /dev/null
1386   
1387    foreach arg $args {
1388        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
1389            regsub -all " " ${val} "\\ " val
1390            set $key $val
1391        }
1392    }
1393   
1394    if {[existsuser ${name}] != 0 || [existsuser ${uid}] != 0} {
1395        return
1396    }
1397   
1398    if {${os.platform} == "darwin"} {
1399        system "niutil -create . /users/${name}"
1400        system "niutil -createprop . /users/${name} name ${name}"
1401        system "niutil -createprop . /users/${name} passwd ${passwd}"
1402        system "niutil -createprop . /users/${name} uid ${uid}"
1403        system "niutil -createprop . /users/${name} gid ${gid}"
1404        system "niutil -createprop . /users/${name} realname ${realname}"
1405        system "niutil -createprop . /users/${name} home ${home}"
1406        system "niutil -createprop . /users/${name} shell ${shell}"
1407    } else {
1408        # XXX adduser is only available for darwin, add more support here
1409        ui_warn "WARNING: adduser is not implemented on ${os.platform}."
1410        ui_warn "The requested user was not created."
1411    }
1412}
1413
1414proc addgroup {name args} {
1415    global os.platform
1416    set gid [nextgid]
1417    set passwd {\*}
1418    set users ""
1419   
1420    foreach arg $args {
1421        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
1422            regsub -all " " ${val} "\\ " val
1423            set $key $val
1424        }
1425    }
1426   
1427    if {[existsgroup ${name}] != 0 || [existsgroup ${gid}] != 0} {
1428        return
1429    }
1430   
1431    if {${os.platform} == "darwin"} {
1432        system "niutil -create . /groups/${name}"
1433        system "niutil -createprop . /groups/${name} name ${name}"
1434        system "niutil -createprop . /groups/${name} gid ${gid}"
1435        system "niutil -createprop . /groups/${name} passwd ${passwd}"
1436        system "niutil -createprop . /groups/${name} users ${users}"
1437    } else {
1438        # XXX addgroup is only available for darwin, add more support here
1439        ui_warn "WARNING: addgroup is not implemented on ${os.platform}."
1440        ui_warn "The requested group was not created."
1441    }
1442}
1443
1444# proc to calculate size of a directory
1445# moved here from portpkg.tcl
1446proc dirSize {dir} {
1447    set size    0;
1448    foreach file [readdir $dir] {
1449        if {[file type [file join $dir $file]] == "link" } {
1450            continue
1451        }
1452        if {[file isdirectory [file join $dir $file]]} {
1453            incr size [dirSize [file join $dir $file]]
1454        } else {
1455            incr size [file size [file join $dir $file]];
1456        }
1457    }
1458    return $size;
1459}
1460
1461# check for a binary in the path
1462# returns an error code if it can not be found
1463proc binaryInPath {binary} {
1464    global env
1465    foreach dir [split $env(PATH) :] { 
1466        if {[file executable [file join $dir $binary]]} {
1467            return [file join $dir $binary]
1468        }
1469    }
1470   
1471    return -code error [format [msgcat::mc "Failed to locate '%s' in path: '%s'"] $binary $env(PATH)];
1472}
1473
1474# Set the UI prefix to something standard (so it can be grepped for in output)
1475proc set_ui_prefix {} {
1476        global UI_PREFIX env
1477        if {[info exists env(UI_PREFIX)]} {
1478                set UI_PREFIX $env(UI_PREFIX)
1479        } else {
1480                set UI_PREFIX "---> "
1481        }
1482}
1483
1484# Use a specified group/version.
1485proc PortGroup {group version} {
1486        global portresourcepath
1487
1488        set groupFile ${portresourcepath}/group/${group}-${version}.tcl
1489
1490        if {[file exists $groupFile]} {
1491                uplevel "source $groupFile"
1492        } else {
1493                ui_warn "Group file could not be located."
1494        }
1495}
1496
1497# check if archive type is supported by current system
1498# returns an error code if it is not
1499proc archiveTypeIsSupported {type} {
1500    global os.platform os.version
1501        set errmsg ""
1502        switch -regex $type {
1503                cp(io|gz) {
1504                        set pax "pax"
1505                        if {[catch {set pax [binaryInPath $pax]} errmsg] == 0} {
1506                                if {[regexp {z$} $type]} {
1507                                        set gzip "gzip"
1508                                        if {[catch {set gzip [binaryInPath $gzip]} errmsg] == 0} {
1509                                                return 0
1510                                        }
1511                                } else {
1512                                        return 0
1513                                }
1514                        }
1515                }
1516                t(ar|bz|gz) {
1517                        set tar "tar"
1518                        if {[catch {set tar [binaryInPath $tar]} errmsg] == 0} {
1519                                if {[regexp {z$} $type]} {
1520                                        if {[regexp {bz$} $type]} {
1521                                                set gzip "bzip2"
1522                                        } else {
1523                                                set gzip "gzip"
1524                                        }
1525                                        if {[catch {set gzip [binaryInPath $gzip]} errmsg] == 0} {
1526                                                return 0
1527                                        }
1528                                } else {
1529                                        return 0
1530                                }
1531                        }
1532                }
1533                xar {
1534                        set xar "xar"
1535                        if {[catch {set xar [binaryInPath $xar]} errmsg] == 0} {
1536                                return 0
1537                        }
1538                }
1539                zip {
1540                        set zip "zip"
1541                        if {[catch {set zip [binaryInPath $zip]} errmsg] == 0} {
1542                                set unzip "unzip"
1543                                if {[catch {set unzip [binaryInPath $unzip]} errmsg] == 0} {
1544                                        return 0
1545                                }
1546                        }
1547                }
1548                default {
1549                        return -code error [format [msgcat::mc "Invalid port archive type '%s' specified!"] $type]
1550                }
1551        }
1552        return -code error [format [msgcat::mc "Unsupported port archive type '%s': %s"] $type $errmsg]
1553}
1554
Note: See TracBrowser for help on using the repository browser.