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

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

Fix setting of environment in command.

When the special variable 'env' is unset, tcl loses track of its connection to the environment, and subsequent changes to the environment do not stick. So instead of unsetting the env array, just remove all values from it.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 48.7 KB
Line 
1# et:ts=4
2# portutil.tcl
3# $Id: portutil.tcl 23362 2007-03-29 23:16:29Z jberry@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# Given a command name, assemble a command string
206# composed of the command options.
207proc command_string {command} {
208    global ${command}.dir ${command}.pre_args ${command}.args ${command}.post_args ${command}.env ${command}.type ${command}.cmd
209   
210    set cmdstring ""
211    if {[info exists ${command}.dir]} {
212        set cmdstring "cd \"[set ${command}.dir]\" &&"
213    }
214   
215    if {[info exists ${command}.cmd]} {
216        foreach string [set ${command}.cmd] {
217            set cmdstring "$cmdstring $string"
218        }
219    } else {
220        set cmdstring "$cmdstring ${command}"
221    }
222    foreach var "${command}.pre_args ${command}.args ${command}.post_args" {
223        if {[info exists $var]} {
224            foreach string [set ${var}] {
225                set cmdstring "$cmdstring $string"
226            }
227        }
228    }
229    ui_debug "Assembled command: '$cmdstring'"
230    return $cmdstring
231}
232
233# Given a command name, execute it with the options.
234# command_exec command [-notty] [command_prefix [command_suffix]]
235# command                       name of the command
236# command_prefix        additional command prefix (typically pipe command)
237# command_suffix        additional command suffix (typically redirection)
238proc command_exec {command args} {
239        global ${command}.env ${command}.env_array env
240        set notty 0
241        set command_prefix ""
242        set command_suffix ""
243
244        if {[llength $args] > 0} {
245                if {[lindex $args 0] == "-notty"} {
246                        set notty 1
247                        set args [lrange $args 1 end]
248                }
249
250                if {[llength $args] > 0} {
251                        set command_prefix [lindex $args 0]
252                        if {[llength $args] > 1} {
253                                set command_suffix [lindex $args 1]
254                        }
255                }
256        }
257       
258        # Set the environment.
259        # If the array doesn't exist, we create it with the value
260        # coming from ${command}.env
261        # Otherwise, it means the caller actually played with the environment
262        # array already (e.g. configure flags).
263        if {![array exists ${command}.env_array]} {
264                parse_environment ${command}
265        }
266       
267        # Debug that.
268    ui_debug "Environment: [environment_array_to_string ${command}.env_array]"
269
270        # Get the command string.
271        set cmdstring [command_string ${command}]
272       
273        # Call this command.
274        # TODO: move that to the system native call?
275        # Save the environment.
276        array set saved_env [array get env]
277        # Set the overriden variables from the portfile.
278        array set env [array get ${command}.env_array]
279        # Call the command.
280        set fullcmdstring "$command_prefix $cmdstring $command_suffix"
281        if {$notty} {
282                set code [catch {system -notty $fullcmdstring} result]
283        } else {
284                set code [catch {system $fullcmdstring} result]
285        }
286        # Unset the command array until next time.
287        array unset ${command}.env_array
288       
289        # Restore the environment.
290        array unset env *
291        array set env [array get saved_env]
292
293        # Return as if system had been called directly.
294        return -code $code $result
295}
296
297# default
298# Sets a variable to the supplied default if it does not exist,
299# and adds a variable trace. The variable traces allows for delayed
300# variable and command expansion in the variable's default value.
301proc default {option val} {
302    global $option option_defaults
303    if {[info exists option_defaults($option)]} {
304        ui_debug "Re-registering default for $option"
305        # remove the old trace
306        trace vdelete $option rwu default_check
307    } else {
308        # If option is already set and we did not set it
309        # do not reset the value
310        if {[info exists $option]} {
311            return
312        }
313    }
314    set option_defaults($option) $val
315    set $option $val
316    trace variable $option rwu default_check
317}
318
319# default_check
320# trace handler to provide delayed variable & command expansion
321# for default variable values
322proc default_check {optionName index op} {
323    global option_defaults $optionName
324    switch $op {
325        w {
326            unset option_defaults($optionName)
327            trace vdelete $optionName rwu default_check
328            return
329        }
330        r {
331            upvar $optionName option
332            uplevel #0 set $optionName $option_defaults($optionName)
333            return
334        }
335        u {
336            unset option_defaults($optionName)
337            trace vdelete $optionName rwu default_check
338            return
339        }
340    }
341}
342
343# variant <provides> [<provides> ...] [requires <requires> [<requires>]]
344# Portfile level procedure to provide support for declaring variants
345proc variant {args} {
346    global all_variants PortInfo
347    upvar $args upargs
348   
349    set len [llength $args]
350    set code [lindex $args end]
351    set args [lrange $args 0 [expr $len - 2]]
352   
353    set ditem [variant_new "temp-variant"]
354   
355    # mode indicates what the arg is interpreted as.
356    # possible mode keywords are: requires, conflicts, provides
357    # The default mode is provides.  Arguments are added to the
358    # most recently specified mode (left to right).
359    set mode "provides"
360    foreach arg $args {
361        switch -exact $arg {
362            provides { set mode "provides" }
363            requires { set mode "requires" }
364            conflicts { set mode "conflicts" }
365            default { ditem_append $ditem $mode $arg }         
366        }
367    }
368    ditem_key $ditem name "[join [ditem_key $ditem provides] -]"
369   
370    # make a user procedure named variant-blah-blah
371    # we will call this procedure during variant-run
372    makeuserproc "variant-[ditem_key $ditem name]" \{$code\}
373    lappend all_variants $ditem
374   
375    # Export provided variant to PortInfo
376    lappend PortInfo(variants) [ditem_key $ditem provides]
377}
378
379# variant_isset name
380# Returns 1 if variant name selected, otherwise 0
381proc variant_isset {name} {
382    global variations
383   
384    if {[info exists variations($name)] && $variations($name) == "+"} {
385        return 1
386    }
387    return 0
388}
389
390# variant_set name
391# Sets variant to run for current portfile
392proc variant_set {name} {
393    global variations
394   
395    set variations($name) +
396}
397
398# variant_unset name
399# Clear variant for current portfile
400proc variant_unset {name} {
401    global variations
402   
403    set variations($name) -
404}
405
406# platform <os> [<release>] [<arch>]
407# Portfile level procedure to provide support for declaring platform-specifics
408# Basically, just wrap 'variant', so that Portfiles' platform declarations can
409# be more readable, and support arch and version specifics
410proc platform {args} {
411    global all_variants PortInfo os.platform os.arch os.version
412    upvar $args upargs
413   
414    set len [llength $args]
415    set code [lindex $args end]
416    set os [lindex $args 0]
417    set args [lrange $args 1 [expr $len - 2]]
418   
419    set ditem [variant_new "temp-variant"]
420   
421    foreach arg $args {
422        if {[regexp {(^[0-9]$)} $arg match result]} {
423            set release $result
424        } elseif {[regexp {([a-zA-Z0-9]*)} $arg match result]} {
425            set arch $result
426        }
427    }
428   
429    # Add the variant for this platform
430    set platform $os
431    if {[info exists release]} { set platform ${platform}_${release} }
432    if {[info exists arch]} { set platform ${platform}_${arch} }
433   
434    variant $platform $code
435   
436    # Set the variant if this platform matches the platform we're on
437    set matches 1
438    if {[info exists os.platform] && ${os.platform} == $os} { 
439        set sel_platform $os
440        if {[info exists os.version] && [info exists release]} {
441            regexp {([0-9]*)[0-9\.]?} ${os.version} match major
442            if {$major == $release } { 
443                set sel_platform ${sel_platform}_${release} 
444            } else {
445                    set matches 0
446            }
447        }
448        if {$matches == 1 && [info exists arch] && [info exists os.arch]} {
449                if {${os.arch} == $arch} {
450                        set sel_platform ${sel_platform}_${arch}
451                } else {
452                        set matches 0
453                }
454    }
455    if {$matches == 1} {
456        variant_set $sel_platform
457    }
458    }
459}
460
461########### Environment utility functions ###########
462
463# Parse the environment string of a command, storing the values into the
464# associated environment array.
465proc parse_environment {command} {
466        global ${command}.env ${command}.env_array
467
468        if {[info exists ${command}.env]} {
469                # Flatten the environment string.
470                set the_environment ""
471                foreach str [set ${command}.env] {
472                        set the_environment "$the_environment $str"
473                }
474       
475                while {[regexp "^(?: *)(\[^= \]+)=(\"|'|)(\[^\"'\].*?)\\2(?: +|$)(.*)$" ${the_environment} matchVar key delimiter value remaining]} {
476                        set the_environment ${remaining}
477                        set ${command}.env_array(${key}) ${value}
478                }
479        } else {
480                array set ${command}.env_array {}
481        }
482}
483
484# Append to the value in the parsed environment.
485# Leave the environment untouched if the value is empty.
486proc append_to_environment_value {command key value} {
487        global ${command}.env_array
488
489        if {[string length $value] == 0} {
490                return
491        }
492
493        # Parse out any delimiter.
494        set append_value $value
495        if {[regexp {^("|')(.*)\1$} $append_value matchVar append_delim matchedValue]} {
496                set append_value $matchedValue
497        }
498
499        if {[info exists ${command}.env_array($key)]} {
500                set original_value [set ${command}.env_array($key)]
501                set ${command}.env_array($key) "${original_value} ${append_value}"
502        } else {
503                set ${command}.env_array($key) $append_value
504        }
505}
506
507# Append several items to a value in the parsed environment.
508proc append_list_to_environment_value {command key vallist} {
509        foreach {value} $vallist {
510                append_to_environment_value ${command} $key $value
511        }
512}
513
514# Build the environment as a string.
515# Remark: this method is only used for debugging purposes.
516proc environment_array_to_string {environment_array} {
517        upvar 1 ${environment_array} env_array
518       
519        set theString ""
520        foreach {key value} [array get env_array] {
521                if {$theString == ""} {
522                        set theString "$key='$value'"
523                } else {
524                        set theString "${theString} $key='$value'"
525                }
526        }
527       
528        return $theString
529}
530
531########### Distname utility functions ###########
532
533# Given a distribution file name, return the appended tag
534# Example: getdisttag distfile.tar.gz:tag1 returns "tag1"
535# / isn't included in the regexp, thus allowing port specification in URLs.
536proc getdisttag {name} {
537    if {[regexp {.+:([0-9A-Za-z_-]+)$} $name match tag]} {
538        return $tag
539    } else {
540        return ""
541    }
542}
543
544# Given a distribution file name, return the name without an attached tag
545# Example : getdistname distfile.tar.gz:tag1 returns "distfile.tar.gz"
546# / isn't included in the regexp, thus allowing port specification in URLs.
547proc getdistname {name} {
548    regexp {(.+):[0-9A-Za-z_-]+$} $name match name
549    return $name
550}
551
552
553########### Misc Utility Functions ###########
554
555# tbool (testbool)
556# If the variable exists in the calling procedure's namespace
557# and is set to "yes", return 1. Otherwise, return 0
558proc tbool {key} {
559    upvar $key $key
560    if {[info exists $key]} {
561        if {[string equal -nocase [set $key] "yes"]} {
562            return 1
563        }
564    }
565    return 0
566}
567
568# ldelete
569# Deletes a value from the supplied list
570proc ldelete {list value} {
571    set ix [lsearch -exact $list $value]
572    if {$ix >= 0} {
573        return [lreplace $list $ix $ix]
574    }
575    return $list
576}
577
578# reinplace
579# Provides "sed in place" functionality
580proc reinplace {pattern args}  {
581    if {$args == ""} {
582        ui_error "reinplace: no value given for parameter \"file\""
583        return -code error "no value given for parameter \"file\" to \"reinplace\"" 
584    }
585   
586    foreach file $args {
587        if {[catch {set tmpfile [mkstemp "/tmp/[file tail $file].sed.XXXXXXXX"]} error]} {
588                global errorInfo
589                ui_debug "$errorInfo"
590            ui_error "reinplace: $error"
591            return -code error "reinplace failed"
592        } else {
593            # Extract the Tcl Channel number
594            set tmpfd [lindex $tmpfile 0]
595            # Set tmpfile to only the file name
596            set tmpfile [lindex $tmpfile 1]
597        }
598       
599        if {[catch {exec sed $pattern < $file >@ $tmpfd} error]} {
600                global errorInfo
601                ui_debug "$errorInfo"
602            ui_error "reinplace: $error"
603            file delete "$tmpfile"
604            close $tmpfd
605            return -code error "reinplace sed(1) failed"
606        }
607       
608        close $tmpfd
609       
610        set attributes [file attributes $file]
611        # We need to overwrite this file
612        if {[catch {file attributes $file -permissions u+w} error]} {
613                global errorInfo
614                ui_debug "$errorInfo"
615            ui_error "reinplace: $error"
616            file delete "$tmpfile"
617            return -code error "reinplace permissions failed"
618        }
619       
620        if {[catch {exec cp $tmpfile $file} error]} {
621                global errorInfo
622                ui_debug "$errorInfo"
623            ui_error "reinplace: $error"
624            file delete "$tmpfile"
625            return -code error "reinplace copy failed"
626        }
627       
628        for {set i 0} {$i < [llength attributes]} {incr i} {
629            set opt [lindex $attributes $i]
630            incr i
631            set arg [lindex $attributes $i]
632            file attributes $file $opt $arg
633        }
634       
635        file delete "$tmpfile"
636    }
637    return
638}
639
640# delete
641# file delete -force by itself doesn't handle directories properly
642# on systems older than Tiger. However we can recurse this thing ourselves
643proc delete {args} {
644    foreach arg $args {
645        ui_debug "delete: $arg"
646        set stack [list $arg]
647        while {[llength $stack] > 0} {
648            set file [lindex $stack 0]
649            if {[string equal [file type $file] directory]} {
650                # it's a directory
651                set children [glob -nocomplain -directory $file * .*]
652                set children [ldelete [ldelete $children $file/.] $file/..]
653                if {[llength $children] > 0} {
654                    set stack [concat $children $stack]
655                } else {
656                    # directory is empty
657                    file delete -force -- $file
658                    set stack [lrange $stack 1 end]
659                }
660            } else {
661                # it's not a directory - kill it now
662                file delete -force -- $file
663                set stack [lrange $stack 1 end]
664            }
665        }
666    }
667}
668
669# touch
670# mimics the BSD touch command
671proc touch {args} {
672    while {[string match -* [lindex $args 0]]} {
673        set arg [string range [lindex $args 0] 1 end]
674        set args [lrange $args 1 end]
675        switch -- $arg {
676            a -
677            c -
678            m {set options($arg) yes}
679            r -
680            t {
681                set narg [lindex $args 0]
682                set args [lrange $args 1 end]
683                if {[string length $narg] == 0} {
684                    return -code error "touch: option requires an argument -- $arg"
685                }
686                set options($arg) $narg
687                set options(rt) $arg ;# later option overrides earlier
688            }
689            - break
690            default {return -code error "touch: illegal option -- $arg"}
691        }
692    }
693   
694    # parse the r/t options
695    if {[info exists options(rt)]} {
696        if {[string equal $options(rt) r]} {
697            # -r
698            # get atime/mtime from the file
699            if {[file exists $options(r)]} {
700                set atime [file atime $options(r)]
701                set mtime [file mtime $options(r)]
702            } else {
703                return -code error "touch: $options(r): No such file or directory"
704            }
705        } else {
706            # -t
707            # parse the time specification
708            # turn it into a CCyymmdd hhmmss
709            set timespec {^(?:(\d\d)?(\d\d))?(\d\d)(\d\d)(\d\d)(\d\d)(?:\.(\d\d))?$}
710            if {[regexp $timespec $options(t) {} CC YY MM DD hh mm SS]} {
711                if {[string length $YY] == 0} {
712                    set year [clock format [clock seconds] -format %Y]
713                } elseif {[string length $CC] == 0} {
714                    if {$YY >= 69 && $YY <= 99} {
715                        set year 19$YY
716                    } else {
717                        set year 20$YY
718                    }
719                } else {
720                    set year $CC$YY
721                }
722                if {[string length $SS] == 0} {
723                    set SS 00
724                }
725                set atime [clock scan "$year$MM$DD $hh$mm$SS"]
726                set mtime $atime
727            } else {
728                return -code error \
729                    {touch: out of range or illegal time specification: [[CC]YY]MMDDhhmm[.SS]}
730            }
731        }
732    } else {
733        set atime [clock seconds]
734        set mtime [clock seconds]
735    }
736   
737    # do we have any files to process?
738    if {[llength $args] == 0} {
739        # print usage
740        ui_msg {usage: touch [-a] [-c] [-m] [-r file] [-t [[CC]YY]MMDDhhmm[.SS]] file ...}
741        return
742    }
743   
744    foreach file $args {
745        if {![file exists $file]} {
746            if {[info exists options(c)]} {
747                continue
748            } else {
749                close [open $file w]
750            }
751        }
752       
753        if {[info exists options(a)] || ![info exists options(m)]} {
754            file atime $file $atime
755        }
756        if {[info exists options(m)] || ![info exists options(a)]} {
757            file mtime $file $mtime
758        }
759    }
760    return
761}
762
763# copy
764proc copy {args} {
765    exec file copy $args
766}
767
768# move
769proc move {args} {
770    exec file rename $args
771}
772
773# ln
774# Mimics the BSD ln implementation
775# ln [-f] [-h] [-s] [-v] source_file [target_file]
776# ln [-f] [-h] [-s] [-v] source_file ... target_dir
777proc ln {args} {
778    while {[string match -* [lindex $args 0]]} {
779        set arg [string range [lindex $args 0] 1 end]
780        set args [lrange $args 1 end]
781        switch -- $arg {
782            f -
783            h -
784            s -
785            v {set options($arg) yes}
786            - break
787            default {return -code error "ln: illegal option -- $arg"}
788        }
789    }
790   
791    if {[llength $args] == 0} {
792        ui_msg {usage: ln [-f] [-h] [-s] [-v] source_file [target_file]}
793        ui_msg {       ln [-f] [-h] [-s] [-v] file ... directory}
794        return
795    } elseif {[llength $args] == 1} {
796        set files $args
797        set target ./
798    } else {
799        set files [lrange $args 0 [expr [llength $args] - 2]]
800        set target [lindex $args end]
801    }
802   
803    foreach file $files {
804        if {[file isdirectory $file] && ![info exists options(s)]} {
805            return -code error "ln: $file: Is a directory"
806        }
807       
808        if {[file isdirectory $target] && ![info exists options(h)]} {
809            set linktarget [file join $target [file tail $file]]
810        } else {
811            set linktarget $target
812        }
813       
814        if {[file exists $linktarget] && ![info exists options(f)]} {
815            return -code error "ln: $linktarget: File exists"
816        }
817       
818        if {[llength $files] > 2} {
819            if {![file exists $linktarget]} {
820                return -code error "ln: $linktarget: No such file or directory"
821            } elseif {![file isdirectory $target]} {
822                # this error isn't striclty what BSD ln gives, but I think it's more useful
823                return -code error "ln: $target: Not a directory"
824            }
825        }
826       
827        if {[info exists options(v)]} {
828            ui_msg "ln: $linktarget -> $file"
829        }
830        if {[info exists options(s)]} {
831            file link -symbolic $linktarget $file
832        } else {
833            file link -hard $linktarget $file
834        }
835    }
836    return
837}
838
839# filefindbypath
840# Provides searching of the standard path for included files
841proc filefindbypath {fname} {
842    global distpath filesdir workdir worksrcdir portpath
843   
844    if {[file readable $portpath/$fname]} {
845        return $portpath/$fname
846    } elseif {[file readable $portpath/$filesdir/$fname]} {
847        return $portpath/$filesdir/$fname
848    } elseif {[file readable $distpath/$fname]} {
849        return $distpath/$fname
850    }
851    return ""
852}
853
854# include
855# Source a file, looking for it along a standard search path.
856proc include {fname} {
857    set tgt [filefindbypath $fname]
858    if {[string length $tgt]} {
859        uplevel "source $tgt"
860    } else {
861        return -code error "Unable to find include file $fname"
862    }
863}
864
865# makeuserproc
866# This procedure re-writes the user-defined custom target to include
867# all the globals in its scope.  This is undeniably ugly, but I haven't
868# thought of any other way to do this.
869proc makeuserproc {name body} {
870    regsub -- "^\{(.*?)" $body "\{ \n foreach g \[info globals\] \{ \n global \$g \n \} \n \\1" body
871    eval "proc $name {} $body"
872}
873
874########### Internal Dependancy Manipulation Procedures ###########
875
876proc target_run {ditem} {
877    global target_state_fd portpath portname portversion portrevision portvariants ports_force variations workpath ports_trace PortInfo
878    set result 0
879    set skipped 0
880    set procedure [ditem_key $ditem procedure]
881    if {$procedure != ""} {
882        set name [ditem_key $ditem name]
883       
884        if {[ditem_contains $ditem init]} {
885            set result [catch {[ditem_key $ditem init] $name} errstr]
886        }
887       
888        if { ![info exists portvariants] } {
889                set portvariants ""
890                set vlist [lsort -ascii [array names variations]]
891
892                # Put together variants in the form +foo+bar for the registry
893                foreach v $vlist {
894                        if { ![string equal $v [option os.platform]] && ![string equal $v [option os.arch]] } {
895                                set portvariants "${portvariants}+${v}"
896                        }
897                }
898        }
899
900        if {$result == 0} {
901                # Skip the step if required and explain why through ui_debug.
902                # 1st case: the step was already done (as mentioned in the state file)
903                if {[check_statefile target $name $target_state_fd]} {
904                    ui_debug "Skipping completed $name ($portname)"
905                    set skipped 1
906                # 2nd case: the step is not to always be performed
907                # and this exact port/version/revision/variants is already installed
908                # and user didn't mention -f
909                # and portfile didn't change since installation.
910                } elseif {[ditem_key $ditem runtype] != "always"
911                        && [registry_exists $portname $portversion $portrevision $portvariants]
912                        && !([info exists ports_force] && $ports_force == "yes")} {
913                                               
914                        # Did the Portfile change since installation?
915                        set regref [registry_open $portname $portversion $portrevision $portvariants]
916                       
917                        set installdate [registry_prop_retr $regref date]
918                        if { $installdate != 0
919                                && $installdate < [file mtime ${portpath}/Portfile]} {
920                                ui_debug "Portfile changed since installation"
921                        } else {
922                                # Say we're skipping.
923                                set skipped 1
924                               
925                                ui_debug "Skipping $name ($portname) since this port is already installed"
926                        }
927                       
928                        # Something to close the registry entry may be called here, if it existed.
929                # 3rd case: the same port/version/revision/Variants is already active
930                # and user didn't mention -f
931                } elseif {$name == "com.apple.activate"
932                        && [registry_exists $portname $portversion $portrevision $portvariants]
933                        && !([info exists ports_force] && $ports_force == "yes")} {
934                       
935                        # Is port active?
936                        set regref [registry_open $portname $portversion $portrevision $portvariants]
937                       
938                        if { [registry_prop_retr $regref active] != 0 } {
939                                # Say we're skipping.
940                                set skipped 1
941                               
942                                ui_debug "Skipping $name ($portname) since this port is already active"
943                        }
944                       
945                }
946                       
947                # otherwise execute the task.
948                if {$skipped == 0} {
949                        set target [ditem_key $ditem provides]
950                        if {([info exists ports_trace]
951                                && $ports_trace == "yes"
952                                && $target != "clean")} {
953                                trace_start $workpath
954
955                                # Enable the fence to prevent any creation/modification
956                                # outside the sandbox.
957                                if {$target != "activate"
958                                        && $target != "archive"
959                                        && $target != "fetch"
960                                        && $target != "install"} {
961                                        trace_enable_fence
962                                }
963                        }
964
965                        # Execute pre-run procedure
966                        if {[ditem_contains $ditem prerun]} {
967                        set result [catch {[ditem_key $ditem prerun] $name} errstr]
968                        }
969                       
970                        if {$result == 0} {
971                        foreach pre [ditem_key $ditem pre] {
972                                ui_debug "Executing $pre"
973                                set result [catch {$pre $name} errstr]
974                                if {$result != 0} { break }
975                        }
976                        }
977                       
978                        if {$result == 0} {
979                        ui_debug "Executing $name ($portname)"
980                        set result [catch {$procedure $name} errstr]
981                        }
982                       
983                        if {$result == 0} {
984                        foreach post [ditem_key $ditem post] {
985                                ui_debug "Executing $post"
986                                set result [catch {$post $name} errstr]
987                                if {$result != 0} { break }
988                        }
989                        }
990                        # Execute post-run procedure
991                        if {[ditem_contains $ditem postrun] && $result == 0} {
992                        set postrun [ditem_key $ditem postrun]
993                        ui_debug "Executing $postrun"
994                        set result [catch {$postrun $name} errstr]
995                        }
996
997                        # Check dependencies & file creations outside workpath.
998                        if {[info exists ports_trace]
999                                && $ports_trace == "yes"
1000                                && $target != "clean"} {
1001                               
1002                                # Don't check dependencies for extract (they're not honored
1003                                # anyway). This avoids warnings about bzip2.
1004                                if {$target != "extract"} {
1005                                        set depends {}
1006                                        set deptypes {}
1007                                       
1008                                        # Determine deptypes to look for based on target
1009                                        switch $target {
1010                                                configure       { set deptypes "depends_lib" }
1011                                               
1012                                                build           { set deptypes "depends_lib depends_build" }
1013                                               
1014                                                destroot        -
1015                                                install         -
1016                                                archive         -
1017                                                pkg                     -
1018                                                mpkg            -
1019                                                rpmpackage      -
1020                                                dpkg            -
1021                                                ""                      { set deptypes "depends_lib depends_build depends_run" }
1022                                        }
1023                                       
1024                                        # Gather the dependencies for deptypes
1025                                        foreach deptype $deptypes {
1026                                                # Add to the list of dependencies if the option exists and isn't empty.
1027                                                if {[info exists PortInfo($deptype)] && $PortInfo($deptype) != ""} {
1028                                                        set depends [concat $depends $PortInfo($deptype)]
1029                                                }
1030                                        }
1031       
1032                                        # Dependencies are in the form verb:[param:]port
1033                                        set depsPorts {}
1034                                        foreach depspec $depends {
1035                                                # grab the portname portion of the depspec
1036                                                set dep_portname [lindex [split $depspec :] end]
1037                                                lappend depsPorts $dep_portname
1038                                        }
1039                                        trace_check_deps $target $depsPorts
1040                                }
1041                               
1042                                trace_check_violations
1043                               
1044                                # End of trace.
1045                                trace_stop
1046                        }
1047                }
1048        }
1049        if {$result == 0} {
1050                # Only write to state file if:
1051                # - we indeed performed this step.
1052                # - this step is not to always be performed
1053                # - this step must be written to file
1054                if {$skipped == 0
1055            && [ditem_key $ditem runtype] != "always"
1056            && [ditem_key $ditem state] != "no"} {
1057                write_statefile target $name $target_state_fd
1058            }
1059        } else {
1060            ui_error "Target $name returned: $errstr"
1061            set result 1
1062        }
1063       
1064    } else {
1065        ui_info "Warning: $name does not have a registered procedure"
1066        set result 1
1067    }
1068   
1069    return $result
1070}
1071
1072proc eval_targets {target} {
1073    global targets target_state_fd portname
1074    set dlist $targets
1075   
1076    # Select the subset of targets under $target
1077    if {$target != ""} {
1078        set matches [dlist_search $dlist provides $target]
1079       
1080        if {[llength $matches] > 0} {
1081            set dlist [dlist_append_dependents $dlist [lindex $matches 0] [list]]
1082            # Special-case 'all'
1083        } elseif {$target != "all"} {
1084            ui_error "unknown target: $target"
1085            return 1
1086        }
1087    }
1088   
1089    # Restore the state from a previous run.
1090    set target_state_fd [open_statefile]
1091   
1092    set dlist [dlist_eval $dlist "" target_run]
1093   
1094    if {[llength $dlist] > 0} {
1095        # somebody broke!
1096        set errstring "Warning: the following items did not execute (for $portname):"
1097        foreach ditem $dlist {
1098            append errstring " [ditem_key $ditem name]"
1099        }
1100        ui_info $errstring
1101        set result 1
1102    } else {
1103        set result 0
1104    }
1105   
1106    close $target_state_fd
1107    return $result
1108}
1109
1110# open_statefile
1111# open file to store name of completed targets
1112proc open_statefile {args} {
1113    global workpath worksymlink portname portpath ports_ignore_older
1114   
1115    if {![file isdirectory $workpath]} {
1116        file mkdir $workpath
1117    }
1118    # flock Portfile
1119    set statefile [file join $workpath .darwinports.${portname}.state]
1120    if {[file exists $statefile]} {
1121        if {![file writable $statefile]} {
1122            return -code error "$statefile is not writable - check permission on port directory"
1123        }
1124        if {!([info exists ports_ignore_older] && $ports_ignore_older == "yes") && [file mtime $statefile] < [file mtime ${portpath}/Portfile]} {
1125            ui_msg "Portfile changed since last build; discarding previous state."
1126            #file delete $statefile
1127            exec rm -rf [file join $workpath]
1128            exec mkdir [file join $workpath]
1129        }
1130    }
1131
1132    # Create a symlink to the workpath for port authors
1133    if {![file isdirectory $worksymlink]} {
1134            exec ln -sf $workpath $worksymlink
1135    }
1136   
1137    set fd [open $statefile a+]
1138    if {[catch {flock $fd -exclusive -noblock} result]} {
1139        if {"$result" == "EAGAIN"} {
1140            ui_msg "Waiting for lock on $statefile"
1141        } elseif {"$result" == "EOPNOTSUPP"} {
1142            # Locking not supported, just return
1143            return $fd
1144        } else {
1145            return -code error "$result obtaining lock on $statefile"
1146        }
1147    }
1148    flock $fd -exclusive
1149    return $fd
1150}
1151
1152# check_statefile
1153# Check completed/selected state of target/variant $name
1154proc check_statefile {class name fd} {
1155    global portpath workdir
1156   
1157    seek $fd 0
1158    while {[gets $fd line] >= 0} {
1159        if {$line == "$class: $name"} {
1160            return 1
1161        }
1162    }
1163    return 0
1164}
1165
1166# write_statefile
1167# Set target $name completed in the state file
1168proc write_statefile {class name fd} {
1169    if {[check_statefile $class $name $fd]} {
1170        return 0
1171    }
1172    seek $fd 0 end
1173    puts $fd "$class: $name"
1174    flush $fd
1175}
1176
1177# check_statefile_variants
1178# Check that recorded selection of variants match the current selection
1179proc check_statefile_variants {variations fd} {
1180    upvar $variations upvariations
1181   
1182    seek $fd 0
1183    while {[gets $fd line] >= 0} {
1184        if {[regexp "variant: (.*)" $line match name]} {
1185            set oldvariations([string range $name 1 end]) [string range $name 0 0]
1186        }
1187    }
1188   
1189    set mismatch 0
1190    if {[array size oldvariations] > 0} {
1191        if {[array size oldvariations] != [array size upvariations]} {
1192            set mismatch 1
1193        } else {
1194            foreach key [array names upvariations *] {
1195                if {![info exists oldvariations($key)] || $upvariations($key) != $oldvariations($key)} {
1196                    set mismatch 1
1197                    break
1198                }
1199            }
1200        }
1201    }
1202   
1203    return $mismatch
1204}
1205
1206########### Port Variants ###########
1207
1208# Each variant which provides a subset of the requested variations
1209# will be chosen.  Returns a list of the selected variants.
1210proc choose_variants {dlist variations} {
1211    upvar $variations upvariations
1212   
1213    set selected [list]
1214   
1215    foreach ditem $dlist {
1216        # Enumerate through the provides, tallying the pros and cons.
1217        set pros 0
1218        set cons 0
1219        set ignored 0
1220        foreach flavor [ditem_key $ditem provides] {
1221            if {[info exists upvariations($flavor)]} {
1222                if {$upvariations($flavor) == "+"} {
1223                    incr pros
1224                } elseif {$upvariations($flavor) == "-"} {
1225                    incr cons
1226                }
1227            } else {
1228                incr ignored
1229            }
1230        }
1231       
1232        if {$cons > 0} { continue }
1233       
1234        if {$pros > 0 && $ignored == 0} {
1235            lappend selected $ditem
1236        }
1237    }
1238    return $selected
1239}
1240
1241proc variant_run {ditem} {
1242    set name [ditem_key $ditem name]
1243    ui_debug "Executing variant $name provides [ditem_key $ditem provides]"
1244   
1245    # test for conflicting variants
1246    foreach v [ditem_key $ditem conflicts] {
1247        if {[variant_isset $v]} {
1248            ui_error "Variant $name conflicts with $v"
1249            return 1
1250        }
1251    }
1252   
1253    # execute proc with same name as variant.
1254    if {[catch "variant-${name}" result]} {
1255        global errorInfo
1256        ui_debug "$errorInfo"
1257        ui_error "Error executing $name: $result"
1258        return 1
1259    }
1260    return 0
1261}
1262
1263proc eval_variants {variations target} {
1264    global all_variants ports_force PortInfo
1265    set dlist $all_variants
1266    set result 0
1267    upvar $variations upvariations
1268    set chosen [choose_variants $dlist upvariations]
1269        set portname $PortInfo(name)
1270
1271        # Check to make sure the requested variations are available with this
1272        # port, if one is not, warn the user and remove the variant from the
1273        # array.
1274        foreach key [array names upvariations *] {
1275                if {![info exists PortInfo(variants)] || 
1276                        [lsearch $PortInfo(variants) $key] == -1} {
1277                        ui_debug "Requested variant $key is not provided by port $portname."
1278                        array unset upvariations $key
1279                }
1280        }
1281
1282    # now that we've selected variants, change all provides [a b c] to [a-b-c]
1283    # this will eliminate ambiguity between item a, b, and a-b while fulfilling requirments.
1284    #foreach obj $dlist {
1285    #    $obj set provides [list [join [$obj get provides] -]]
1286    #}
1287   
1288    set newlist [list]
1289    foreach variant $chosen {
1290                set newlist [dlist_append_dependents $dlist $variant $newlist]
1291    }
1292   
1293    set dlist [dlist_eval $newlist "" variant_run]
1294    if {[llength $dlist] > 0} {
1295                return 1
1296    }
1297   
1298    # Make sure the variations match those stored in the statefile.
1299    # If they don't match, print an error indicating a 'port clean'
1300    # should be performed. 
1301    # - Skip this test if the statefile is empty.
1302    # - Skip this test if performing a clean.
1303    # - Skip this test if ports_force was specified.
1304   
1305    if {$target != "clean" && 
1306        !([info exists ports_force] && $ports_force == "yes")} {
1307        set state_fd [open_statefile]
1308       
1309        if {[check_statefile_variants upvariations $state_fd]} {
1310            ui_error "Requested variants do not match original selection.\nPlease perform 'port clean $portname' or specify the force option."
1311            set result 1
1312        } else {
1313            # Write variations out to the statefile
1314            foreach key [array names upvariations *] {
1315                write_statefile variant $upvariations($key)$key $state_fd
1316            }
1317        }
1318       
1319        close $state_fd
1320    }
1321   
1322    return $result
1323}
1324
1325# Target class definition.
1326
1327# constructor for target object
1328proc target_new {name procedure} {
1329    global targets
1330    set ditem [ditem_create]
1331   
1332    ditem_key $ditem name $name
1333    ditem_key $ditem procedure $procedure
1334   
1335    lappend targets $ditem
1336   
1337    return $ditem
1338}
1339
1340proc target_provides {ditem args} {
1341    global targets
1342    # Register the pre-/post- hooks for use in Portfile.
1343    # Portfile syntax: pre-fetch { puts "hello world" }
1344    # User-code exceptions are caught and returned as a result of the target.
1345    # Thus if the user code breaks, dependent targets will not execute.
1346    foreach target $args {
1347        set origproc [ditem_key $ditem procedure]
1348        set ident [ditem_key $ditem name]
1349        if {[info commands $target] != ""} {
1350            ui_debug "$ident registered provides '$target', a pre-existing procedure. Target override will not be provided"
1351        } else {
1352            proc $target {args} "
1353                variable proc_index
1354                set proc_index \[llength \[ditem_key $ditem proc\]\]
1355                ditem_key $ditem procedure proc-${ident}-${target}-\${proc_index}
1356                proc proc-${ident}-${target}-\${proc_index} {name} \"
1357                    if {\\\[catch userproc-${ident}-${target}-\${proc_index} result\\\]} {
1358                        return -code error \\\$result
1359                    } else {
1360                        return 0
1361                    }
1362                \"
1363                proc do-$target {} { $origproc $target }
1364                makeuserproc userproc-${ident}-${target}-\${proc_index} \$args
1365            "
1366        }
1367        proc pre-$target {args} "
1368            variable proc_index
1369            set proc_index \[llength \[ditem_key $ditem pre\]\]
1370            ditem_append $ditem pre proc-pre-${ident}-${target}-\${proc_index}
1371            proc proc-pre-${ident}-${target}-\${proc_index} {name} \"
1372                if {\\\[catch userproc-pre-${ident}-${target}-\${proc_index} result\\\]} {
1373                    return -code error \\\$result
1374                } else {
1375                    return 0
1376                }
1377            \"
1378            makeuserproc userproc-pre-${ident}-${target}-\${proc_index} \$args
1379        "
1380        proc post-$target {args} "
1381            variable proc_index
1382            set proc_index \[llength \[ditem_key $ditem post\]\]
1383            ditem_append $ditem post proc-post-${ident}-${target}-\${proc_index}
1384            proc proc-post-${ident}-${target}-\${proc_index} {name} \"
1385                if {\\\[catch userproc-post-${ident}-${target}-\${proc_index} result\\\]} {
1386                    return -code error \\\$result
1387                } else {
1388                    return 0
1389                }
1390            \"
1391            makeuserproc userproc-post-${ident}-${target}-\${proc_index} \$args
1392        "
1393    }
1394    eval ditem_append $ditem provides $args
1395}
1396
1397proc target_requires {ditem args} {
1398    eval ditem_append $ditem requires $args
1399}
1400
1401proc target_uses {ditem args} {
1402    eval ditem_append $ditem uses $args
1403}
1404
1405proc target_deplist {ditem args} {
1406    eval ditem_append $ditem deplist $args
1407}
1408
1409proc target_prerun {ditem args} {
1410    eval ditem_append $ditem prerun $args
1411}
1412
1413proc target_postrun {ditem args} {
1414    eval ditem_append $ditem postrun $args
1415}
1416
1417proc target_runtype {ditem args} {
1418    eval ditem_append $ditem runtype $args
1419}
1420
1421proc target_state {ditem args} {
1422    eval ditem_append $ditem state $args
1423}
1424
1425proc target_init {ditem args} {
1426    eval ditem_append $ditem init $args
1427}
1428
1429##### variant class #####
1430
1431# constructor for variant objects
1432proc variant_new {name} {
1433    set ditem [ditem_create]
1434    ditem_key $ditem name $name
1435    return $ditem
1436}
1437
1438proc handle_default_variants {option action args} {
1439    global variations
1440    switch -regex $action {
1441        set|append {
1442            foreach v $args {
1443                if {[regexp {([-+])([-A-Za-z0-9_]+)} $v whole val variant]} {
1444                    if {![info exists variations($variant)]} {
1445                        set variations($variant) $val
1446                    }
1447                }
1448            }
1449        }
1450        delete {
1451            # xxx
1452        }
1453    }
1454}
1455
1456
1457# builds the specified port (looked up in the index) to the specified target
1458# doesn't yet support options or variants...
1459# newworkpath defines the port's workpath - useful for when one port relies
1460# on the source, etc, of another
1461proc portexec_int {portname target {newworkpath ""}} {
1462    ui_debug "Executing $target ($portname)"
1463    set variations [list]
1464    if {$newworkpath == ""} {
1465        array set options [list]
1466    } else {
1467        set options(workpath) ${newworkpath}
1468    }
1469    # Escape regex special characters
1470    regsub -all "(\\(){1}|(\\)){1}|(\\{1}){1}|(\\+){1}|(\\{1}){1}|(\\{){1}|(\\}){1}|(\\^){1}|(\\$){1}|(\\.){1}|(\\\\){1}" $portname "\\\\&" search_string
1471   
1472    set res [dport_search ^$search_string\$]
1473    if {[llength $res] < 2} {
1474        ui_error "Dependency $portname not found"
1475        return -1
1476    }
1477   
1478    array set portinfo [lindex $res 1]
1479    set porturl $portinfo(porturl)
1480    if {[catch {set worker [dport_open $porturl [array get options] $variations]} result]} {
1481                global errorInfo
1482                ui_debug "$errorInfo"
1483        ui_error "Opening $portname $target failed: $result"
1484        return -1
1485    }
1486    if {[catch {dport_exec $worker $target} result] || $result != 0} {
1487                global errorInfo
1488                ui_debug "$errorInfo"
1489        ui_error "Execution $portname $target failed: $result"
1490        dport_close $worker
1491        return -1
1492    }
1493    dport_close $worker
1494   
1495    return 0
1496}
1497
1498# portfile primitive that calls portexec_int with newworkpath == ${workpath}
1499proc portexec {portname target} {
1500    global workpath
1501    return [portexec_int $portname $target $workpath]
1502}
1503
1504proc adduser {name args} {
1505    global os.platform
1506    set passwd {\*}
1507    set uid [nextuid]
1508    set gid [existsgroup nogroup]
1509    set realname ${name}
1510    set home /dev/null
1511    set shell /dev/null
1512   
1513    foreach arg $args {
1514        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
1515            regsub -all " " ${val} "\\ " val
1516            set $key $val
1517        }
1518    }
1519   
1520    if {[existsuser ${name}] != 0 || [existsuser ${uid}] != 0} {
1521        return
1522    }
1523   
1524    if {${os.platform} == "darwin"} {
1525        system "niutil -create . /users/${name}"
1526        system "niutil -createprop . /users/${name} name ${name}"
1527        system "niutil -createprop . /users/${name} passwd ${passwd}"
1528        system "niutil -createprop . /users/${name} uid ${uid}"
1529        system "niutil -createprop . /users/${name} gid ${gid}"
1530        system "niutil -createprop . /users/${name} realname ${realname}"
1531        system "niutil -createprop . /users/${name} home ${home}"
1532        system "niutil -createprop . /users/${name} shell ${shell}"
1533    } else {
1534        # XXX adduser is only available for darwin, add more support here
1535        ui_warn "WARNING: adduser is not implemented on ${os.platform}."
1536        ui_warn "The requested user was not created."
1537    }
1538}
1539
1540proc addgroup {name args} {
1541    global os.platform
1542    set gid [nextgid]
1543    set passwd {\*}
1544    set users ""
1545   
1546    foreach arg $args {
1547        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
1548            regsub -all " " ${val} "\\ " val
1549            set $key $val
1550        }
1551    }
1552   
1553    if {[existsgroup ${name}] != 0 || [existsgroup ${gid}] != 0} {
1554        return
1555    }
1556   
1557    if {${os.platform} == "darwin"} {
1558        system "niutil -create . /groups/${name}"
1559        system "niutil -createprop . /groups/${name} name ${name}"
1560        system "niutil -createprop . /groups/${name} gid ${gid}"
1561        system "niutil -createprop . /groups/${name} passwd ${passwd}"
1562        system "niutil -createprop . /groups/${name} users ${users}"
1563    } else {
1564        # XXX addgroup is only available for darwin, add more support here
1565        ui_warn "WARNING: addgroup is not implemented on ${os.platform}."
1566        ui_warn "The requested group was not created."
1567    }
1568}
1569
1570# proc to calculate size of a directory
1571# moved here from portpkg.tcl
1572proc dirSize {dir} {
1573    set size    0;
1574    foreach file [readdir $dir] {
1575        if {[file type [file join $dir $file]] == "link" } {
1576            continue
1577        }
1578        if {[file isdirectory [file join $dir $file]]} {
1579            incr size [dirSize [file join $dir $file]]
1580        } else {
1581            incr size [file size [file join $dir $file]];
1582        }
1583    }
1584    return $size;
1585}
1586
1587# check for a binary in the path
1588# returns an error code if it can not be found
1589proc binaryInPath {binary} {
1590    global env
1591    foreach dir [split $env(PATH) :] { 
1592        if {[file executable [file join $dir $binary]]} {
1593            return [file join $dir $binary]
1594        }
1595    }
1596   
1597    return -code error [format [msgcat::mc "Failed to locate '%s' in path: '%s'"] $binary $env(PATH)];
1598}
1599
1600# Set the UI prefix to something standard (so it can be grepped for in output)
1601proc set_ui_prefix {} {
1602        global UI_PREFIX env
1603        if {[info exists env(UI_PREFIX)]} {
1604                set UI_PREFIX $env(UI_PREFIX)
1605        } else {
1606                set UI_PREFIX "---> "
1607        }
1608}
1609
1610# Use a specified group/version.
1611proc PortGroup {group version} {
1612        global portresourcepath
1613
1614        set groupFile ${portresourcepath}/group/${group}-${version}.tcl
1615
1616        if {[file exists $groupFile]} {
1617                uplevel "source $groupFile"
1618        } else {
1619                ui_warn "Group file could not be located."
1620        }
1621}
1622
1623# check if archive type is supported by current system
1624# returns an error code if it is not
1625proc archiveTypeIsSupported {type} {
1626    global os.platform os.version
1627        set errmsg ""
1628        switch -regex $type {
1629                cp(io|gz) {
1630                        set pax "pax"
1631                        if {[catch {set pax [binaryInPath $pax]} errmsg] == 0} {
1632                                if {[regexp {z$} $type]} {
1633                                        set gzip "gzip"
1634                                        if {[catch {set gzip [binaryInPath $gzip]} errmsg] == 0} {
1635                                                return 0
1636                                        }
1637                                } else {
1638                                        return 0
1639                                }
1640                        }
1641                }
1642                t(ar|bz|gz) {
1643                        set tar "tar"
1644                        if {[catch {set tar [binaryInPath $tar]} errmsg] == 0} {
1645                                if {[regexp {z$} $type]} {
1646                                        if {[regexp {bz$} $type]} {
1647                                                set gzip "bzip2"
1648                                        } else {
1649                                                set gzip "gzip"
1650                                        }
1651                                        if {[catch {set gzip [binaryInPath $gzip]} errmsg] == 0} {
1652                                                return 0
1653                                        }
1654                                } else {
1655                                        return 0
1656                                }
1657                        }
1658                }
1659                xar {
1660                        set xar "xar"
1661                        if {[catch {set xar [binaryInPath $xar]} errmsg] == 0} {
1662                                return 0
1663                        }
1664                }
1665                zip {
1666                        set zip "zip"
1667                        if {[catch {set zip [binaryInPath $zip]} errmsg] == 0} {
1668                                set unzip "unzip"
1669                                if {[catch {set unzip [binaryInPath $unzip]} errmsg] == 0} {
1670                                        return 0
1671                                }
1672                        }
1673                }
1674                default {
1675                        return -code error [format [msgcat::mc "Invalid port archive type '%s' specified!"] $type]
1676                }
1677        }
1678        return -code error [format [msgcat::mc "Unsupported port archive type '%s': %s"] $type $errmsg]
1679}
1680
Note: See TracBrowser for help on using the repository browser.