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

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

Fix a dangerous situation with the delete command where it would follow symlinks to directories

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