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

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

Reimplement delete using fs-traverse - *much* smaller now.
Add test file for portutil, currently only tests delete

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