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

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

Fix tracing to work *much* better. Also fix depends validation to actually validate each depspec instead of just finding a single one within the list, and to stop validating on unset. Include ChangeLog entry. Fixes #11868

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