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

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

Add -E flag to reinplace

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