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

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

New option universal_variant to disable the automatic addition of the universal variant on MacOS X, with new tests to test this behavior.

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