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

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

Remove two completely useless upvar $args upargs lines from variant and platform procs

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