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

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

port1.0/portutil.tcl:
tracemode: always allow gzip in destroot phase, as it is used to compress man pages

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 67.8 KB
Line 
1# -*- coding: utf-8; mode: tcl; tab-width: 4; indent-tabs-mode: nil; c-basic-offset: 4 -*- vim:fenc=utf-8:filetype=tcl:et:sw=4:ts=4:sts=4
2# portutil.tcl
3# $Id: portutil.tcl 35675 2008-04-01 23:27:08Z raimue@macports.org $
4#
5# Copyright (c) 2004 Robert Shaw <rshaw@opendarwin.org>
6# Copyright (c) 2002 Apple Computer, Inc.
7# Copyright (c) 2006, 2007 Markus W. Weissmann <mww@macports.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 macports_dlist 1.0
38package require macports_util 1.0
39package require msgcat
40package require porttrace 1.0
41
42global targets target_uniqid all_variants
43
44set targets [list]
45set target_uniqid 0
46
47set all_variants [list]
48
49########### External High Level Procedures ###########
50
51namespace eval options {
52}
53
54# option
55# This is an accessor for Portfile options.  Targets may use
56# this in the same style as the standard Tcl "set" procedure.
57#   name  - the name of the option to read or write
58#   value - an optional value to assign to the option
59
60proc option {name args} {
61    # XXX: right now we just transparently use globals
62    # eventually this will need to bridge the options between
63    # the Portfile's interpreter and the target's interpreters.
64    global $name
65    if {[llength $args] > 0} {
66        ui_debug "setting option $name to $args"
67        set $name [lindex $args 0]
68    }
69    return [set $name]
70}
71
72# exists
73# This is an accessor for Portfile options.  Targets may use
74# this procedure to test for the existence of a Portfile option.
75#   name - the name of the option to test for existence
76
77proc exists {name} {
78    # XXX: right now we just transparently use globals
79    # eventually this will need to bridge the options between
80    # the Portfile's interpreter and the target's interpreters.
81    global $name
82    return [info exists $name]
83}
84
85##
86# Handle an option
87#
88# @param option name of the option
89# @param args arguments
90proc handle_option {option args} {
91    global $option user_options option_procs
92
93    if {![info exists user_options($option)]} {
94        set $option $args
95    }
96}
97
98##
99# Handle option-append
100#
101# @param option name of the option
102# @param args arguments
103proc handle_option-append {option args} {
104    global $option user_options option_procs
105
106    if {![info exists user_options($option)]} {
107        if {[info exists $option]} {
108            set $option [concat [set $option] $args]
109        } else {
110            set $option $args
111        }
112    }
113}
114
115##
116# Handle option-delete
117#
118# @param option name of the option
119# @param args arguments
120proc handle_option-delete {option args} {
121    global $option user_options option_procs
122
123    if {![info exists user_options($option)] && [info exists $option]} {
124        set temp [set $option]
125        foreach val $args {
126            set temp [ldelete $temp $val]
127        }
128        if {$temp eq ""} {
129            unset $option
130        } else {
131            set $option $temp
132        }
133    }
134}
135
136# options
137# Exports options in an array as externally callable procedures
138# Thus, "options name date" would create procedures named "name"
139# and "date" that set global variables "name" and "date", respectively
140# When an option is modified in any way, options::$option is called,
141# if it exists
142# Arguments: <list of options>
143proc options {args} {
144    foreach option $args {
145        interp alias {} $option {} handle_option $option
146        interp alias {} $option-append {} handle_option-append $option
147        interp alias {} $option-delete {} handle_option-delete $option
148    }
149}
150
151##
152# Export options into PortInfo
153#
154# @param option the name of the option
155# @param action set or delete
156# @param value the value to be set, defaults to an empty string
157proc options::export {option action {value ""}} {
158    global $option PortInfo
159    switch $action {
160        set {
161            set PortInfo($option) $value
162        }
163        delete {
164            unset PortInfo($option)
165        }
166    }
167}
168
169##
170# Export multiple options
171#
172# @param args list of ports to be exported
173proc options_export {args} {
174    foreach option $args {
175        option_proc $option options::export
176    }
177}
178
179##
180# Print a warning for deprecated ports
181#
182# @param args list of ports to be exported
183proc warn_deprecated_option {option action args} {
184    global portname $option $newoption
185
186    ui_warn "Port $portname using deprecated option \"$option\"."
187}
188
189proc warn_superseded_option {option newport action args} {
190    global portname $option $newoption
191
192    if {$action != "read"} {
193        $newoption [set $option]
194    } else {
195        ui_warn "Port $portname using deprecated option \"$option\"."
196        $option [set $newoption]
197    }
198}
199
200
201##
202# Causes a warning to be printed when an option is set or accessed
203#
204# @param option name of the option
205# @param newoption name of a superseding option
206proc option_deprecate {option {newoption ""} } {
207    # If a new option is specified, default the option to {${newoption}}
208    # Display a warning
209    if {$newoption != ""} {
210        option_proc $option warn_deprecated_option $option
211    } else {
212        option_proc $option warn_superseded_option $option $newoption
213    }
214
215}
216
217##
218# Registers a proc to be called when an option is changed
219#
220# @param option the name of the option
221# @param args name of proc (and additional arguments)
222proc option_proc {option args} {
223    global option_procs $option
224    if {[info exists option_procs($option)]} {
225        set option_procs($option) [concat $option_procs($option) $args]
226        # we're already tracing
227    } else {
228        set option_procs($option) $args
229        trace add variable $option {read write unset} option_proc_trace
230    }
231}
232
233# option_proc_trace
234# trace handler for option reads. Calls option procedures with correct arguments.
235proc option_proc_trace {optionName index op} {
236    global option_procs
237    upvar $optionName $optionName
238    switch $op {
239        write {
240            foreach p $option_procs($optionName) {
241                $p $optionName set [set $optionName]
242            }
243        }
244        read {
245            foreach p $option_procs($optionName) {
246                $p $optionName read
247            }
248        }
249        unset {
250            foreach p $option_procs($optionName) {
251                if {[catch {$p $optionName delete} result]} {
252                    ui_debug "error during unset trace ($p): $result\n$::errorInfo"
253                }
254            }
255            trace add variable $optionName {read write unset} option_proc_trace
256        }
257    }
258}
259
260# commands
261# Accepts a list of arguments, of which several options are created
262# and used to form a standard set of command options.
263proc commands {args} {
264    foreach option $args {
265        options use_${option} ${option}.dir ${option}.pre_args ${option}.args ${option}.post_args ${option}.env ${option}.type ${option}.cmd
266    }
267}
268
269# Given a command name, assemble a command string
270# composed of the command options.
271proc command_string {command} {
272    global ${command}.dir ${command}.pre_args ${command}.args ${command}.post_args ${command}.cmd
273   
274    if {[info exists ${command}.dir]} {
275        append cmdstring "cd \"[set ${command}.dir]\" &&"
276    }
277   
278    if {[info exists ${command}.cmd]} {
279        foreach string [set ${command}.cmd] {
280            append cmdstring " $string"
281        }
282    } else {
283        append cmdstring " ${command}"
284    }
285
286    foreach var "${command}.pre_args ${command}.args ${command}.post_args" {
287        if {[info exists $var]} {
288            foreach string [set ${var}] {
289                append cmdstring " ${string}"
290            }
291        }
292    }
293
294    ui_debug "Assembled command: '$cmdstring'"
295    return $cmdstring
296}
297
298# Given a command name, execute it with the options.
299# command_exec command [-notty] [command_prefix [command_suffix]]
300# command           name of the command
301# command_prefix    additional command prefix (typically pipe command)
302# command_suffix    additional command suffix (typically redirection)
303proc command_exec {command args} {
304    global ${command}.env ${command}.env_array env
305    set notty 0
306    set command_prefix ""
307    set command_suffix ""
308
309    if {[llength $args] > 0} {
310        if {[lindex $args 0] == "-notty"} {
311            set notty 1
312            set args [lrange $args 1 end]
313        }
314
315        if {[llength $args] > 0} {
316            set command_prefix [lindex $args 0]
317            if {[llength $args] > 1} {
318                set command_suffix [lindex $args 1]
319            }
320        }
321    }
322   
323    # Set the environment.
324    # If the array doesn't exist, we create it with the value
325    # coming from ${command}.env
326    # Otherwise, it means the caller actually played with the environment
327    # array already (e.g. configure flags).
328    if {![array exists ${command}.env_array]} {
329        parse_environment ${command}
330    }
331    if {[option macosx_deployment_target] ne ""} {
332        set ${command}.env_array("MACOSX_DEPLOYMENT_TARGET") [option macosx_deployment_target]
333    }
334   
335    # Debug that.
336    ui_debug "Environment: [environment_array_to_string ${command}.env_array]"
337
338    # Get the command string.
339    set cmdstring [command_string ${command}]
340   
341    # Call this command.
342    # TODO: move that to the system native call?
343    # Save the environment.
344    array set saved_env [array get env]
345    # Set the overriden variables from the portfile.
346    array set env [array get ${command}.env_array]
347    # Call the command.
348    set fullcmdstring "$command_prefix $cmdstring $command_suffix"
349    if {$notty} {
350        set code [catch {system -notty $fullcmdstring} result]
351    } else {
352        set code [catch {system $fullcmdstring} result]
353    }
354    # Unset the command array until next time.
355    array unset ${command}.env_array
356   
357    # Restore the environment.
358    array unset env *
359    array set env [array get saved_env]
360
361    # Return as if system had been called directly.
362    return -code $code $result
363}
364
365# default
366# Sets a variable to the supplied default if it does not exist,
367# and adds a variable trace. The variable traces allows for delayed
368# variable and command expansion in the variable's default value.
369proc default {option val} {
370    global $option option_defaults
371    if {[info exists option_defaults($option)]} {
372        ui_debug "Re-registering default for $option"
373        # remove the old trace
374        trace vdelete $option rwu default_check
375    } else {
376        # If option is already set and we did not set it
377        # do not reset the value
378        if {[info exists $option]} {
379            return
380        }
381    }
382    set option_defaults($option) $val
383    set $option $val
384    trace variable $option rwu default_check
385}
386
387# default_check
388# trace handler to provide delayed variable & command expansion
389# for default variable values
390proc default_check {optionName index op} {
391    global option_defaults $optionName
392    switch $op {
393        w {
394            unset option_defaults($optionName)
395            trace vdelete $optionName rwu default_check
396            return
397        }
398        r {
399            upvar $optionName option
400            uplevel #0 set $optionName $option_defaults($optionName)
401            return
402        }
403        u {
404            unset option_defaults($optionName)
405            trace vdelete $optionName rwu default_check
406            return
407        }
408    }
409}
410
411# variant <provides> [<provides> ...] [requires <requires> [<requires>]]
412# Portfile level procedure to provide support for declaring variants
413proc variant {args} {
414    global all_variants PortInfo
415   
416    set len [llength $args]
417    set code [lindex $args end]
418    set args [lrange $args 0 [expr $len - 2]]
419   
420    set ditem [variant_new "temp-variant"]
421   
422    # mode indicates what the arg is interpreted as.
423    # possible mode keywords are: requires, conflicts, provides
424    # The default mode is provides.  Arguments are added to the
425    # most recently specified mode (left to right).
426    set mode "provides"
427    foreach arg $args {
428        switch -exact $arg {
429            description -
430            provides -
431            requires -
432            conflicts { set mode $arg }
433            default { ditem_append $ditem $mode $arg }     
434        }
435    }
436    ditem_key $ditem name "[join [ditem_key $ditem provides] -]"
437
438    # make a user procedure named variant-blah-blah
439    # we will call this procedure during variant-run
440    makeuserproc "variant-[ditem_key $ditem name]" \{$code\}
441   
442    # Export provided variant to PortInfo
443    # (don't list it twice if the variant was already defined, which can happen
444    # with universal or group code).
445    set variant_provides [ditem_key $ditem provides]
446    if {[variant_exists $variant_provides]} {
447        # This variant was already defined. Remove it from the dlist.
448        variant_remove_ditem $variant_provides
449    } else {
450        lappend PortInfo(variants) $variant_provides
451        set vdesc [join [ditem_key $ditem description]]
452        if {$vdesc != ""} {
453            lappend PortInfo(variant_desc) $variant_provides $vdesc
454        }
455    }
456
457    # Finally append the ditem to the dlist.
458    lappend all_variants $ditem
459}
460
461# variant_isset name
462# Returns 1 if variant name selected, otherwise 0
463proc variant_isset {name} {
464    global variations
465   
466    if {[info exists variations($name)] && $variations($name) == "+"} {
467        return 1
468    }
469    return 0
470}
471
472# variant_set name
473# Sets variant to run for current portfile
474proc variant_set {name} {
475    global variations
476    set variations($name) +
477}
478
479# variant_unset name
480# Clear variant for current portfile
481proc variant_unset {name} {
482    global variations
483   
484    set variations($name) -
485}
486
487# variant_undef name
488# Undefine a variant for the current portfile.
489proc variant_undef {name} {
490    global variations PortInfo
491   
492    # Remove it from the list of selected variations.
493    array unset variations $name
494
495    # Remove the variant from the portinfo.
496    if {[info exists PortInfo(variants)]} {
497        set variant_index [lsearch -exact $PortInfo(variants) $name]
498        if {$variant_index >= 0} {
499            set new_list [lreplace $PortInfo(variants) $variant_index $variant_index]
500            if {"$new_list" == {}} {
501                unset PortInfo(variants) 
502            } else {
503                set PortInfo(variants) $new_list
504            }
505        }
506    }
507   
508    # And from the dlist.
509    variant_remove_ditem $name
510}
511
512# variant_remove_ditem name
513# Remove variant name's ditem from the all_variants dlist
514proc variant_remove_ditem {name} {
515    global all_variants
516    set item_index 0
517    foreach variant_item $all_variants {
518        set item_provides [ditem_key $variant_item provides]
519        if {$item_provides == $name} {
520            set all_variants [lreplace $all_variants $item_index $item_index]
521            break
522        }
523       
524        incr item_index
525    }
526}
527
528# variant_exists name
529# determine if a variant exists.
530proc variant_exists {name} {
531    global PortInfo
532    if {[info exists PortInfo(variants)] &&
533      [lsearch -exact $PortInfo(variants) $name] >= 0} {
534        return 1
535    }
536
537    return 0
538}
539
540# platform <os> [<release>] [<arch>]
541# Portfile level procedure to provide support for declaring platform-specifics
542# Basically, just wrap 'variant', so that Portfiles' platform declarations can
543# be more readable, and support arch and version specifics
544proc platform {args} {
545    global all_variants PortInfo os.platform os.arch os.version os.major
546   
547    set len [llength $args]
548    set code [lindex $args end]
549    set os [lindex $args 0]
550    set args [lrange $args 1 [expr $len - 2]]
551   
552    set ditem [variant_new "temp-variant"]
553   
554    foreach arg $args {
555        if {[regexp {(^[0-9]$)} $arg match result]} {
556            set release $result
557        } elseif {[regexp {([a-zA-Z0-9]*)} $arg match result]} {
558            set arch $result
559        }
560    }
561   
562    # Add the variant for this platform
563    set platform $os
564    if {[info exists release]} { set platform ${platform}_${release} }
565    if {[info exists arch]} { set platform ${platform}_${arch} }
566   
567    # Pick up a unique name.
568    if {[variant_exists $platform]} {
569        set suffix 1
570        while {[variant_exists "$platform-$suffix"]} {
571            incr suffix
572        }
573       
574        set platform "$platform-$suffix"
575    }
576    variant $platform $code
577   
578    # Set the variant if this platform matches the platform we're on
579    set matches 1
580    if {[info exists os.platform] && ${os.platform} == $os} { 
581        set sel_platform $os
582        if {[info exists os.major] && [info exists release]} {
583            if {${os.major} == $release } { 
584                set sel_platform ${sel_platform}_${release} 
585            } else {
586                set matches 0
587            }
588        }
589        if {$matches == 1 && [info exists arch] && [info exists os.arch]} {
590            if {${os.arch} == $arch} {
591                set sel_platform ${sel_platform}_${arch}
592            } else {
593                set matches 0
594            }
595        }
596        if {$matches == 1} {
597            variant_set $sel_platform
598        }
599    }
600}
601
602########### Environment utility functions ###########
603
604# Parse the environment string of a command, storing the values into the
605# associated environment array.
606proc parse_environment {command} {
607    global ${command}.env ${command}.env_array
608
609    if {[info exists ${command}.env]} {
610        # Flatten the environment string.
611        set the_environment [join [set ${command}.env]]
612   
613        while {[regexp "^(?: *)(\[^= \]+)=(\"|'|)(\[^\"'\]*?)\\2(?: +|$)(.*)$" ${the_environment} matchVar key delimiter value remaining]} {
614            set the_environment ${remaining}
615            set ${command}.env_array(${key}) ${value}
616        }
617    } else {
618        array set ${command}.env_array {}
619    }
620}
621
622# Append to the value in the parsed environment.
623# Leave the environment untouched if the value is empty.
624proc append_to_environment_value {command key value} {
625    global ${command}.env_array
626
627    if {[string length $value] == 0} {
628        return
629    }
630
631    # Parse out any delimiter.
632    set append_value $value
633    if {[regexp {^("|')(.*)\1$} $append_value matchVar append_delim matchedValue]} {
634        set append_value $matchedValue
635    }
636
637    if {[info exists ${command}.env_array($key)]} {
638        set original_value [set ${command}.env_array($key)]
639        set ${command}.env_array($key) "${original_value} ${append_value}"
640    } else {
641        set ${command}.env_array($key) $append_value
642    }
643}
644
645# Append several items to a value in the parsed environment.
646proc append_list_to_environment_value {command key vallist} {
647    foreach {value} $vallist {
648        append_to_environment_value ${command} $key $value
649    }
650}
651
652# Build the environment as a string.
653# Remark: this method is only used for debugging purposes.
654proc environment_array_to_string {environment_array} {
655    upvar 1 ${environment_array} env_array
656   
657    set theString ""
658    foreach {key value} [array get env_array] {
659        if {$theString == ""} {
660            set theString "$key='$value'"
661        } else {
662            set theString "${theString} $key='$value'"
663        }
664    }
665   
666    return $theString
667}
668
669########### Distname utility functions ###########
670
671# Given a distribution file name, return the appended tag
672# Example: getdisttag distfile.tar.gz:tag1 returns "tag1"
673# / isn't included in the regexp, thus allowing port specification in URLs.
674proc getdisttag {name} {
675    if {[regexp {.+:([0-9A-Za-z_-]+)$} $name match tag]} {
676        return $tag
677    } else {
678        return ""
679    }
680}
681
682# Given a distribution file name, return the name without an attached tag
683# Example : getdistname distfile.tar.gz:tag1 returns "distfile.tar.gz"
684# / isn't included in the regexp, thus allowing port specification in URLs.
685proc getdistname {name} {
686    regexp {(.+):[0-9A-Za-z_-]+$} $name match name
687    return $name
688}
689
690
691########### Misc Utility Functions ###########
692
693# tbool (testbool)
694# If the variable exists in the calling procedure's namespace
695# and is set to "yes", return 1. Otherwise, return 0
696proc tbool {key} {
697    upvar $key $key
698    if {[info exists $key]} {
699        if {[string equal -nocase [set $key] "yes"]} {
700            return 1
701        }
702    }
703    return 0
704}
705
706# ldelete
707# Deletes a value from the supplied list
708proc ldelete {list value} {
709    set ix [lsearch -exact $list $value]
710    if {$ix >= 0} {
711        return [lreplace $list $ix $ix]
712    }
713    return $list
714}
715
716# reinplace
717# Provides "sed in place" functionality
718proc reinplace {args}  {
719    set extended 0
720    while 1 {
721        set arg [lindex $args 0]
722        if {[string index $arg 0] eq "-"} {
723            set args [lrange $args 1 end]
724            switch [string range $arg 1 end] {
725                E {
726                    set extended 1
727                }
728                - {
729                    break
730                }
731                default {
732                    error "reinplace: unknown flag '$arg'"
733                }
734            }
735        } else {
736            break
737        }
738    }
739    if {[llength $args] < 2} {
740        error "reinplace ?-E? pattern file ..."
741    }
742    set pattern [lindex $args 0]
743    set files [lrange $args 1 end]
744   
745    foreach file $files {
746        if {[catch {set tmpfile [mkstemp "/tmp/[file tail $file].sed.XXXXXXXX"]} error]} {
747            global errorInfo
748            ui_debug "$errorInfo"
749            ui_error "reinplace: $error"
750            return -code error "reinplace failed"
751        } else {
752            # Extract the Tcl Channel number
753            set tmpfd [lindex $tmpfile 0]
754            # Set tmpfile to only the file name
755            set tmpfile [lindex $tmpfile 1]
756        }
757   
758        set cmdline $portutil::autoconf::sed_command
759        if {$extended} {
760            lappend cmdline $portutil::autoconf::sed_ext_flag
761        }
762        set cmdline [concat $cmdline [list $pattern < $file >@ $tmpfd]]
763        if {[catch {eval exec $cmdline} error]} {
764            global errorInfo
765            ui_debug "$errorInfo"
766            ui_error "reinplace: $error"
767            file delete "$tmpfile"
768            close $tmpfd
769            return -code error "reinplace sed(1) failed"
770        }
771   
772        close $tmpfd
773   
774        set attributes [file attributes $file]
775        # We need to overwrite this file
776        if {[catch {file attributes $file -permissions u+w} error]} {
777            global errorInfo
778            ui_debug "$errorInfo"
779            ui_error "reinplace: $error"
780            file delete "$tmpfile"
781            return -code error "reinplace permissions failed"
782        }
783   
784        if {[catch {exec cp $tmpfile $file} error]} {
785            global errorInfo
786            ui_debug "$errorInfo"
787            ui_error "reinplace: $error"
788            file delete "$tmpfile"
789            return -code error "reinplace copy failed"
790        }
791   
792        for {set i 0} {$i < [llength attributes]} {incr i} {
793            set opt [lindex $attributes $i]
794            incr i
795            set arg [lindex $attributes $i]
796            file attributes $file $opt $arg
797        }
798       
799        file delete "$tmpfile"
800    }
801    return
802}
803
804# delete
805# file delete -force by itself doesn't handle directories properly
806# on systems older than Tiger. Lets recurse using fs-traverse instead
807proc delete {args} {
808    ui_debug "delete: $args"
809    fs-traverse -depth file $args {
810        file delete -force -- $file
811        continue
812    }
813}
814
815# touch
816# mimics the BSD touch command
817proc touch {args} {
818    while {[string match -* [lindex $args 0]]} {
819        set arg [string range [lindex $args 0] 1 end]
820        set args [lrange $args 1 end]
821        switch -- $arg {
822            a -
823            c -
824            m {set options($arg) yes}
825            r -
826            t {
827                set narg [lindex $args 0]
828                set args [lrange $args 1 end]
829                if {[string length $narg] == 0} {
830                    return -code error "touch: option requires an argument -- $arg"
831                }
832                set options($arg) $narg
833                set options(rt) $arg ;# later option overrides earlier
834            }
835            - break
836            default {return -code error "touch: illegal option -- $arg"}
837        }
838    }
839   
840    # parse the r/t options
841    if {[info exists options(rt)]} {
842        if {[string equal $options(rt) r]} {
843            # -r
844            # get atime/mtime from the file
845            if {[file exists $options(r)]} {
846                set atime [file atime $options(r)]
847                set mtime [file mtime $options(r)]
848            } else {
849                return -code error "touch: $options(r): No such file or directory"
850            }
851        } else {
852            # -t
853            # parse the time specification
854            # turn it into a CCyymmdd hhmmss
855            set timespec {^(?:(\d\d)?(\d\d))?(\d\d)(\d\d)(\d\d)(\d\d)(?:\.(\d\d))?$}
856            if {[regexp $timespec $options(t) {} CC YY MM DD hh mm SS]} {
857                if {[string length $YY] == 0} {
858                    set year [clock format [clock seconds] -format %Y]
859                } elseif {[string length $CC] == 0} {
860                    if {$YY >= 69 && $YY <= 99} {
861                        set year 19$YY
862                    } else {
863                        set year 20$YY
864                    }
865                } else {
866                    set year $CC$YY
867                }
868                if {[string length $SS] == 0} {
869                    set SS 00
870                }
871                set atime [clock scan "$year$MM$DD $hh$mm$SS"]
872                set mtime $atime
873            } else {
874                return -code error \
875                    {touch: out of range or illegal time specification: [[CC]YY]MMDDhhmm[.SS]}
876            }
877        }
878    } else {
879        set atime [clock seconds]
880        set mtime [clock seconds]
881    }
882   
883    # do we have any files to process?
884    if {[llength $args] == 0} {
885        # print usage
886        ui_msg {usage: touch [-a] [-c] [-m] [-r file] [-t [[CC]YY]MMDDhhmm[.SS]] file ...}
887        return
888    }
889   
890    foreach file $args {
891        if {![file exists $file]} {
892            if {[info exists options(c)]} {
893                continue
894            } else {
895                close [open $file w]
896            }
897        }
898       
899        if {[info exists options(a)] || ![info exists options(m)]} {
900            file atime $file $atime
901        }
902        if {[info exists options(m)] || ![info exists options(a)]} {
903            file mtime $file $mtime
904        }
905    }
906    return
907}
908
909# copy
910proc copy {args} {
911    eval file copy $args
912}
913
914# move
915proc move {args} {
916    eval file rename $args
917}
918
919# ln
920# Mimics the BSD ln implementation
921# ln [-f] [-h] [-s] [-v] source_file [target_file]
922# ln [-f] [-h] [-s] [-v] source_file ... target_dir
923proc ln {args} {
924    while {[string match -* [lindex $args 0]]} {
925        set arg [string range [lindex $args 0] 1 end]
926        if {[string length $arg] > 1} {
927            set remainder -[string range $arg 1 end]
928            set arg [string range $arg 0 0]
929            set args [lreplace $args 0 0 $remainder]
930        } else {
931            set args [lreplace $args 0 0]
932        }
933        switch -- $arg {
934            f -
935            h -
936            s -
937            v {set options($arg) yes}
938            - break
939            default {return -code error "ln: illegal option -- $arg"}
940        }
941    }
942   
943    if {[llength $args] == 0} {
944        ui_msg {usage: ln [-f] [-h] [-s] [-v] source_file [target_file]}
945        ui_msg {       ln [-f] [-h] [-s] [-v] file ... directory}
946        return
947    } elseif {[llength $args] == 1} {
948        set files $args
949        set target ./
950    } else {
951        set files [lrange $args 0 [expr [llength $args] - 2]]
952        set target [lindex $args end]
953    }
954   
955    foreach file $files {
956        if {[file isdirectory $file] && ![info exists options(s)]} {
957            return -code error "ln: $file: Is a directory"
958        }
959       
960        if {[file isdirectory $target] && ([file type $target] ne "link" || ![info exists options(h)])} {
961            set linktarget [file join $target [file tail $file]]
962        } else {
963            set linktarget $target
964        }
965       
966        if {![catch {file type $linktarget}]} {
967            if {[info exists options(f)]} {
968                file delete $linktarget
969            } else {
970                return -code error "ln: $linktarget: File exists"
971            }
972        }
973       
974        if {[llength $files] > 2} {
975            if {![file exists $linktarget]} {
976                return -code error "ln: $linktarget: No such file or directory"
977            } elseif {![file isdirectory $target]} {
978                # this error isn't striclty what BSD ln gives, but I think it's more useful
979                return -code error "ln: $target: Not a directory"
980            }
981        }
982       
983        if {[info exists options(v)]} {
984            ui_msg "ln: $linktarget -> $file"
985        }
986        if {[info exists options(s)]} {
987            symlink $file $linktarget
988        } else {
989            file link -hard $linktarget $file
990        }
991    }
992    return
993}
994
995# filefindbypath
996# Provides searching of the standard path for included files
997proc filefindbypath {fname} {
998    global distpath filesdir worksrcdir portpath
999   
1000    if {[file readable $portpath/$fname]} {
1001        return $portpath/$fname
1002    } elseif {[file readable $portpath/$filesdir/$fname]} {
1003        return $portpath/$filesdir/$fname
1004    } elseif {[file readable $distpath/$fname]} {
1005        return $distpath/$fname
1006    }
1007    return ""
1008}
1009
1010# include
1011# Source a file, looking for it along a standard search path.
1012proc include {fname} {
1013    set tgt [filefindbypath $fname]
1014    if {[string length $tgt]} {
1015        uplevel "source $tgt"
1016    } else {
1017        return -code error "Unable to find include file $fname"
1018    }
1019}
1020
1021# makeuserproc
1022# This procedure re-writes the user-defined custom target to include
1023# all the globals in its scope.  This is undeniably ugly, but I haven't
1024# thought of any other way to do this.
1025proc makeuserproc {name body} {
1026    regsub -- "^\{(.*?)" $body "\{ \n foreach g \[info globals\] \{ \n global \$g \n \} \n \\1" body
1027    eval "proc $name {} $body"
1028}
1029
1030# backup
1031# Operates on universal_filelist, creates universal_archlist
1032# Save single-architecture files, a temporary location, preserving the original
1033# directory structure.
1034
1035proc backup {arch} {
1036    global universal_archlist universal_filelist workpath
1037    lappend universal_archlist ${arch}
1038    foreach file ${universal_filelist} {
1039        set filedir [file dirname $file]
1040        xinstall -d ${workpath}/${arch}/${filedir}
1041        xinstall ${file} ${workpath}/${arch}/${filedir}
1042    }
1043}
1044
1045# lipo
1046# Operates on universal_filelist, universal_archlist.
1047# Run lipo(1) on a list of single-arch files.
1048
1049proc lipo {} {
1050    global universal_archlist universal_filelist workpath
1051    foreach file ${universal_filelist} {
1052        xinstall -d [file dirname $file]
1053        file delete ${file}
1054        set lipoSources ""
1055        foreach arch $universal_archlist {
1056            append lipoSources "-arch ${arch} ${workpath}/${arch}/${file} "
1057        }
1058        system "lipo ${lipoSources}-create -output ${file}"
1059    }
1060}
1061
1062
1063# unobscure maintainer addresses as used in Portfiles
1064# We allow two obscured forms:
1065#   (1) User name only with no domain:
1066#           foo implies foo@macports.org
1067#   (2) Mangled name:
1068#           subdomain.tld:username implies username@subdomain.tld
1069#
1070proc unobscure_maintainers { list } {
1071    set result {}
1072    foreach m $list {
1073        if {[string first "@" $m] < 0} {
1074            if {[string first ":" $m] >= 0} {
1075                set m [regsub -- "(.*):(.*)" $m "\\2@\\1"]
1076            } else {
1077                set m "$m@macports.org"
1078            }
1079        }
1080        lappend result $m
1081    }
1082    return $result
1083}
1084
1085
1086
1087
1088########### Internal Dependency Manipulation Procedures ###########
1089
1090proc target_run {ditem} {
1091    global target_state_fd portpath portname portversion portrevision portvariants ports_force variations workpath ports_trace PortInfo
1092    set result 0
1093    set skipped 0
1094    set procedure [ditem_key $ditem procedure]
1095           
1096    if {[ditem_key $ditem state] != "no"} {
1097        set target_state_fd [open_statefile]
1098    }
1099       
1100    if {$procedure != ""} {
1101        set name [ditem_key $ditem name]
1102   
1103        if {[ditem_contains $ditem init]} {
1104            set result [catch {[ditem_key $ditem init] $name} errstr]
1105        }
1106   
1107        if {$result == 0} {
1108            # Skip the step if required and explain why through ui_debug.
1109            # 1st case: the step was already done (as mentioned in the state file)
1110            if {[ditem_key $ditem state] != "no"
1111                    && [check_statefile target $name $target_state_fd]} {
1112                ui_debug "Skipping completed $name ($portname)"
1113                set skipped 1
1114            # 2nd case: the step is not to always be performed
1115            # and this exact port/version/revision/variants is already installed
1116            # and user didn't mention -f
1117            # and portfile didn't change since installation.
1118            } elseif {[ditem_key $ditem runtype] != "always"
1119              && [registry_exists $portname $portversion $portrevision $portvariants]
1120              && !([info exists ports_force] && $ports_force == "yes")} {
1121                       
1122                # Did the Portfile change since installation?
1123                set regref [registry_open $portname $portversion $portrevision $portvariants]
1124           
1125                set installdate [registry_prop_retr $regref date]
1126                if { $installdate != 0
1127                  && $installdate < [file mtime ${portpath}/Portfile]} {
1128                    ui_debug "Portfile changed since installation"
1129                } else {
1130                    # Say we're skipping.
1131                    set skipped 1
1132               
1133                    ui_debug "Skipping $name ($portname) since this port is already installed"
1134                }
1135           
1136                # Something to close the registry entry may be called here, if it existed.
1137                # 3rd case: the same port/version/revision/Variants is already active
1138                # and user didn't mention -f
1139            } elseif {$name == "org.macports.activate"
1140              && [registry_exists $portname $portversion $portrevision $portvariants]
1141              && !([info exists ports_force] && $ports_force == "yes")} {
1142           
1143                # Is port active?
1144                set regref [registry_open $portname $portversion $portrevision $portvariants]
1145           
1146                if { [registry_prop_retr $regref active] != 0 } {
1147                    # Say we're skipping.
1148                    set skipped 1
1149               
1150                    ui_msg "Skipping $name ($portname $portvariants) since this port is already active"
1151                }
1152               
1153            }
1154           
1155            # otherwise execute the task.
1156            if {$skipped == 0} {
1157                set target [ditem_key $ditem provides]
1158           
1159                # Execute pre-run procedure
1160                if {[ditem_contains $ditem prerun]} {
1161                    set result [catch {[ditem_key $ditem prerun] $name} errstr]
1162                }
1163           
1164                #start tracelib
1165                if {($result ==0
1166                  && [info exists ports_trace]
1167                  && $ports_trace == "yes"
1168                  && $target != "clean")} {
1169                    trace_start $workpath
1170
1171                    # Enable the fence to prevent any creation/modification
1172                    # outside the sandbox.
1173                    if {$target != "activate"
1174                      && $target != "archive"
1175                      && $target != "fetch"
1176                      && $target != "install"} {
1177                        trace_enable_fence
1178                    }
1179           
1180                    # collect deps
1181                   
1182                    # Don't check dependencies for extract (they're not honored
1183                    # anyway). This avoids warnings about bzip2.
1184                    if {$target != "extract"} {
1185                        set depends {}
1186                        set deptypes {}
1187                   
1188                        # Determine deptypes to look for based on target
1189                        switch $target {
1190                            configure   { set deptypes "depends_lib depends_build" }
1191                           
1192                            build       { set deptypes "depends_lib depends_build" }
1193                       
1194                            test        -
1195                            destroot    -
1196                            install     -
1197                            archive     -
1198                            pkg         -
1199                            mpkg        -
1200                            rpm         -
1201                            srpm        -
1202                            dpkg        -
1203                            activate    -
1204                            ""          { set deptypes "depends_lib depends_build depends_run" }
1205                        }
1206                   
1207                        # Gather the dependencies for deptypes
1208                        foreach deptype $deptypes {
1209                            # Add to the list of dependencies if the option exists and isn't empty.
1210                            if {[info exists PortInfo($deptype)] && $PortInfo($deptype) != ""} {
1211                                set depends [concat $depends $PortInfo($deptype)]
1212                            }
1213                        }
1214   
1215                        # Dependencies are in the form verb:[param:]port
1216                        set depsPorts {}
1217                        foreach depspec $depends {
1218                            # grab the portname portion of the depspec
1219                            set dep_portname [lindex [split $depspec :] end]
1220                            lappend depsPorts $dep_portname
1221                        }
1222
1223                        # always allow gzip in destroot as it is used to compress man pages
1224                        if {$target == "destroot"} {
1225                            lappend depsPorts "gzip"
1226                        }
1227                   
1228                        set portlist $depsPorts
1229                        foreach depName $depsPorts {
1230                            set portlist [concat $portlist [recursive_collect_deps $depName $deptypes]]
1231                        }
1232                        #uniquer from http://aspn.activestate.com/ASPN/Cookbook/Tcl/Recipe/147663
1233                        array set a [split "[join $portlist {::}]:" {:}]
1234                        set depsPorts [array names a]
1235                   
1236                        if {[llength $deptypes] > 0} {tracelib setdeps $depsPorts}
1237                    }
1238                }
1239           
1240                if {$result == 0} {
1241                    foreach pre [ditem_key $ditem pre] {
1242                        ui_debug "Executing $pre"
1243                        set result [catch {$pre $name} errstr]
1244                        if {$result != 0} { break }
1245                    }
1246                }
1247           
1248                if {$result == 0} {
1249                ui_debug "Executing $name ($portname)"
1250                set result [catch {$procedure $name} errstr]
1251                }
1252           
1253                if {$result == 0} {
1254                    foreach post [ditem_key $ditem post] {
1255                        ui_debug "Executing $post"
1256                        set result [catch {$post $name} errstr]
1257                        if {$result != 0} { break }
1258                    }
1259                }
1260                # Execute post-run procedure
1261                if {[ditem_contains $ditem postrun] && $result == 0} {
1262                    set postrun [ditem_key $ditem postrun]
1263                    ui_debug "Executing $postrun"
1264                    set result [catch {$postrun $name} errstr]
1265                }
1266
1267                # Check dependencies & file creations outside workpath.
1268                if {[info exists ports_trace]
1269                  && $ports_trace == "yes"
1270                  && $target!="clean"} {
1271               
1272                    tracelib closesocket
1273               
1274                    trace_check_violations
1275               
1276                    # End of trace.
1277                    trace_stop
1278                }
1279            }
1280        }
1281        if {$result == 0} {
1282            # Only write to state file if:
1283            # - we indeed performed this step.
1284            # - this step is not to always be performed
1285            # - this step must be written to file
1286            if {$skipped == 0
1287          && [ditem_key $ditem runtype] != "always"
1288          && [ditem_key $ditem state] != "no"} {
1289            write_statefile target $name $target_state_fd
1290            }
1291        } else {
1292            ui_error "Target $name returned: $errstr"
1293            set result 1
1294        }
1295   
1296    } else {
1297        ui_info "Warning: $name does not have a registered procedure"
1298        set result 1
1299    }
1300   
1301    if {[ditem_key $ditem state] != "no"} {
1302        close $target_state_fd
1303    }
1304
1305    return $result
1306}
1307
1308# recursive found depends for portname
1309# It isn't ideal, because it scan many ports multiple time
1310proc recursive_collect_deps {portname deptypes} \
1311{
1312    set res [mport_search ^$portname\$]
1313    if {[llength $res] < 2} \
1314    {
1315        return {}
1316    }
1317
1318    set depends {}
1319
1320    array set portinfo [lindex $res 1]
1321    foreach deptype $deptypes \
1322    {
1323        if {[info exists portinfo($deptype)] && $portinfo($deptype) != ""} \
1324        {
1325            set depends [concat $depends $portinfo($deptype)]
1326        }
1327    }
1328   
1329    set portdeps {}
1330    foreach depspec $depends \
1331    {
1332        set portname [lindex [split $depspec :] end]
1333        lappend portdeps $portname
1334        set portdeps [concat $portdeps [recursive_collect_deps $portname $deptypes]]
1335    }
1336    return $portdeps
1337}
1338
1339
1340proc eval_targets {target} {
1341    global targets target_state_fd portname
1342    set dlist $targets
1343   
1344    # Select the subset of targets under $target
1345    if {$target != ""} {
1346        set matches [dlist_search $dlist provides $target]
1347   
1348        if {[llength $matches] > 0} {
1349            set dlist [dlist_append_dependents $dlist [lindex $matches 0] [list]]
1350            # Special-case 'all'
1351        } elseif {$target != "all"} {
1352            ui_error "unknown target: $target"
1353            return 1
1354        }
1355    }
1356   
1357    set dlist [dlist_eval $dlist "" target_run]
1358   
1359    if {[llength $dlist] > 0} {
1360        # somebody broke!
1361        set errstring "Warning: the following items did not execute (for $portname):"
1362        foreach ditem $dlist {
1363            append errstring " [ditem_key $ditem name]"
1364        }
1365        ui_info $errstring
1366        set result 1
1367    } else {
1368        set result 0
1369    }
1370   
1371    return $result
1372}
1373
1374# open_statefile
1375# open file to store name of completed targets
1376proc open_statefile {args} {
1377    global workpath worksymlink place_worksymlink portname portpath ports_ignore_older
1378   
1379    if {![file isdirectory $workpath]} {
1380        file mkdir $workpath
1381    }
1382    # flock Portfile
1383    set statefile [file join $workpath .macports.${portname}.state]
1384    if {[file exists $statefile]} {
1385        if {![file writable $statefile]} {
1386            return -code error "$statefile is not writable - check permission on port directory"
1387        }
1388        if {!([info exists ports_ignore_older] && $ports_ignore_older == "yes") && [file mtime $statefile] < [file mtime ${portpath}/Portfile]} {
1389            ui_msg "Portfile changed since last build; discarding previous state."
1390            #file delete $statefile
1391            exec rm -rf [file join $workpath]
1392            exec mkdir [file join $workpath]
1393        }
1394    }
1395
1396    # Create a symlink to the workpath for port authors
1397    if {[tbool place_worksymlink] && ![file isdirectory $worksymlink]} {
1398        exec ln -sf $workpath $worksymlink
1399    }
1400   
1401    set fd [open $statefile a+]
1402    if {[catch {flock $fd -exclusive -noblock} result]} {
1403        if {"$result" == "EAGAIN"} {
1404            ui_msg "Waiting for lock on $statefile"
1405    } elseif {"$result" == "EOPNOTSUPP"} {
1406        # Locking not supported, just return
1407        return $fd
1408        } else {
1409            return -code error "$result obtaining lock on $statefile"
1410        }
1411    }
1412    flock $fd -exclusive
1413    return $fd
1414}
1415
1416# check_statefile
1417# Check completed/selected state of target/variant $name
1418proc check_statefile {class name fd} {
1419    seek $fd 0
1420    while {[gets $fd line] >= 0} {
1421        if {$line == "$class: $name"} {
1422            return 1
1423        }
1424    }
1425    return 0
1426}
1427
1428# write_statefile
1429# Set target $name completed in the state file
1430proc write_statefile {class name fd} {
1431    if {[check_statefile $class $name $fd]} {
1432        return 0
1433    }
1434    seek $fd 0 end
1435    puts $fd "$class: $name"
1436    flush $fd
1437}
1438
1439# check_statefile_variants
1440# Check that recorded selection of variants match the current selection
1441proc check_statefile_variants {variations fd} {
1442    upvar $variations upvariations
1443   
1444    seek $fd 0
1445    while {[gets $fd line] >= 0} {
1446        if {[regexp "variant: (.*)" $line match name]} {
1447            set oldvariations([string range $name 1 end]) [string range $name 0 0]
1448        }
1449    }
1450   
1451    set mismatch 0
1452    if {[array size oldvariations] > 0} {
1453        if {[array size oldvariations] != [array size upvariations]} {
1454            set mismatch 1
1455        } else {
1456            foreach key [array names upvariations *] {
1457                if {![info exists oldvariations($key)] || $upvariations($key) != $oldvariations($key)} {
1458                set mismatch 1
1459                break
1460                }
1461            }
1462        }
1463    }
1464   
1465    return $mismatch
1466}
1467
1468########### Port Variants ###########
1469
1470# Each variant which provides a subset of the requested variations
1471# will be chosen.  Returns a list of the selected variants.
1472proc choose_variants {dlist variations} {
1473    upvar $variations upvariations
1474   
1475    set selected [list]
1476   
1477    foreach ditem $dlist {
1478        # Enumerate through the provides, tallying the pros and cons.
1479        set pros 0
1480        set cons 0
1481        set ignored 0
1482        foreach flavor [ditem_key $ditem provides] {
1483            if {[info exists upvariations($flavor)]} {
1484                if {$upvariations($flavor) == "+"} {
1485                    incr pros
1486                } elseif {$upvariations($flavor) == "-"} {
1487                    incr cons
1488                }
1489            } else {
1490                incr ignored
1491            }
1492        }
1493   
1494        if {$cons > 0} { continue }
1495   
1496        if {$pros > 0 && $ignored == 0} {
1497            lappend selected $ditem
1498        }
1499    }
1500    return $selected
1501}
1502
1503proc variant_run {ditem} {
1504    set name [ditem_key $ditem name]
1505    ui_debug "Executing variant $name provides [ditem_key $ditem provides]"
1506   
1507    # test for conflicting variants
1508    foreach v [ditem_key $ditem conflicts] {
1509        if {[variant_isset $v]} {
1510            ui_error "Variant $name conflicts with $v"
1511            return 1
1512        }
1513    }
1514   
1515    # execute proc with same name as variant.
1516    if {[catch "variant-${name}" result]} {
1517        global errorInfo
1518        ui_debug "$errorInfo"
1519        ui_error "Error executing $name: $result"
1520        return 1
1521    }
1522    return 0
1523}
1524
1525# Given a list of variant specifications, return a canonical string form
1526# for the registry.
1527    # The strategy is as follows: regardless of how some collection of variants
1528    # was turned on or off, a particular instance of the port is uniquely
1529    # characterized by the set of variants that are *on*. Thus, record those
1530    # variants in a string in a standard order as +var1+var2 etc.
1531    # We can skip the platform and architecture since those are always
1532    # requested.  XXX: Is that really true? What if the user explicitly
1533    # overrides the platform and architecture variants? Will the registry get
1534    # bollixed? It would seem safer to me to just leave in all the variants that
1535    # are on, but for now I'm just leaving the skipping code as it was in the
1536    # previous version.
1537proc canonicalize_variants {variants} {
1538    array set vara $variants
1539    set result ""
1540    set vlist [lsort -ascii [array names vara]]
1541    foreach v $vlist {
1542        if {$vara($v) == "+" && $v ne [option os.platform] && $v ne [option os.arch]} {
1543            append result +$v
1544        }
1545    }
1546    return $result
1547}
1548
1549proc eval_variants {variations} {
1550    global all_variants ports_force PortInfo portvariants
1551    set dlist $all_variants
1552    upvar $variations upvariations
1553    set chosen [choose_variants $dlist upvariations]
1554    set portname $PortInfo(name)
1555
1556    # Check to make sure the requested variations are available with this
1557    # port, if one is not, warn the user and remove the variant from the
1558    # array.
1559    foreach key [array names upvariations *] {
1560        if {![info exists PortInfo(variants)] ||
1561            [lsearch $PortInfo(variants) $key] == -1} {
1562            ui_debug "Requested variant $key is not provided by port $portname."
1563            array unset upvariations $key
1564        }
1565    }
1566
1567    # now that we've selected variants, change all provides [a b c] to [a-b-c]
1568    # this will eliminate ambiguity between item a, b, and a-b while fulfilling requirments.
1569    #foreach obj $dlist {
1570    #    $obj set provides [list [join [$obj get provides] -]]
1571    #}
1572   
1573    set newlist [list]
1574    foreach variant $chosen {
1575        set newlist [dlist_append_dependents $dlist $variant $newlist]
1576    }
1577   
1578    set dlist [dlist_eval $newlist "" variant_run]
1579    if {[llength $dlist] > 0} {
1580        return 1
1581    }
1582
1583    # Now compute the true active array of variants. Note we do not
1584    # change upvariations any further, since that represents the
1585    # requested list of variations; but the registry for consistency
1586    # must encode the actual list of variants evaluated, however that
1587    # came to pass (dependencies, defaults, etc.) While we're at it,
1588    # it's convenient to check for inconsistent requests for
1589    # variations, namely foo +requirer -required where the 'requirer'
1590    # variant requires the 'required' one.
1591    array set activevariants [list]
1592    foreach dvar $newlist {
1593        set thevar [ditem_key $dvar provides]
1594        if {[info exists upvariations($thevar)] && $upvariations($thevar) eq "-"} {
1595            set chosenlist ""
1596            foreach choice $chosen {
1597                lappend chosenlist +[ditem_key $choice provides]
1598            }
1599            ui_error "Inconsistent variant specification: $portname variant +$thevar is required by at least one of $chosenlist, but specified -$thevar"
1600            return 1
1601        }
1602        set activevariants($thevar) "+"
1603    }
1604
1605    # Record a canonical variant string, used e.g. in accessing the registry
1606    set portvariants [canonicalize_variants [array get activevariants]]
1607
1608    # XXX: I suspect it would actually work better in the following
1609    # block to record the activevariants in the statefile rather than
1610    # the upvariations, since as far as I can see different sets of
1611    # upvariations which amount to the same activevariants in the end
1612    # can share all aspects of the build. But I'm leaving this alone
1613    # for the time being, so that someone with more extensive
1614    # experience can examine the idea before putting it into
1615    # action. -- GlenWhitney
1616
1617    return 0
1618}
1619
1620proc check_variants {variations target} {
1621    global ports_force PortInfo
1622    upvar $variations upvariations
1623    set result 0
1624    set portname $PortInfo(name)
1625   
1626    # Make sure the variations match those stored in the statefile.
1627    # If they don't match, print an error indicating a 'port clean'
1628    # should be performed. 
1629    # - Skip this test if the statefile is empty.
1630    # - Skip this test if performing a clean or submit.
1631    # - Skip this test if ports_force was specified.
1632   
1633    # TODO: Don't hardcode this list of targets here,
1634    #       check for [ditem_key $mport state] == "no" somewhere else instead
1635    if { [lsearch "clean submit lint livecheck" $target] < 0 &&
1636        !([info exists ports_force] && $ports_force == "yes")} {
1637       
1638        set state_fd [open_statefile]
1639   
1640        if {[check_statefile_variants upvariations $state_fd]} {
1641            ui_error "Requested variants do not match original selection.\nPlease perform 'port clean $portname' or specify the force option."
1642            set result 1
1643        } else {
1644            # Write variations out to the statefile
1645            foreach key [array names upvariations *] {
1646            write_statefile variant $upvariations($key)$key $state_fd
1647            }
1648        }
1649       
1650        close $state_fd
1651    }
1652   
1653    return $result
1654}
1655
1656# Target class definition.
1657
1658# constructor for target object
1659proc target_new {name procedure} {
1660    global targets
1661    set ditem [ditem_create]
1662   
1663    ditem_key $ditem name $name
1664    ditem_key $ditem procedure $procedure
1665   
1666    lappend targets $ditem
1667   
1668    return $ditem
1669}
1670
1671proc target_provides {ditem args} {
1672    global targets
1673    # Register the pre-/post- hooks for use in Portfile.
1674    # Portfile syntax: pre-fetch { puts "hello world" }
1675    # User-code exceptions are caught and returned as a result of the target.
1676    # Thus if the user code breaks, dependent targets will not execute.
1677    foreach target $args {
1678        set origproc [ditem_key $ditem procedure]
1679        set ident [ditem_key $ditem name]
1680        if {[info commands $target] != ""} {
1681            ui_debug "$ident registered provides '$target', a pre-existing procedure. Target override will not be provided"
1682        } else {
1683            proc $target {args} "
1684                variable proc_index
1685                set proc_index \[llength \[ditem_key $ditem proc\]\]
1686                ditem_key $ditem procedure proc-${ident}-${target}-\${proc_index}
1687                proc proc-${ident}-${target}-\${proc_index} {name} \"
1688                    if {\\\[catch userproc-${ident}-${target}-\${proc_index} result\\\]} {
1689                        return -code error \\\$result
1690                    } else {
1691                        return 0
1692                    }
1693                \"
1694                proc do-$target {} { $origproc $target }
1695                makeuserproc userproc-${ident}-${target}-\${proc_index} \$args
1696            "
1697        }
1698        proc pre-$target {args} "
1699            variable proc_index
1700            set proc_index \[llength \[ditem_key $ditem pre\]\]
1701            ditem_append $ditem pre proc-pre-${ident}-${target}-\${proc_index}
1702            proc proc-pre-${ident}-${target}-\${proc_index} {name} \"
1703                if {\\\[catch userproc-pre-${ident}-${target}-\${proc_index} result\\\]} {
1704                    return -code error \\\$result
1705                } else {
1706                    return 0
1707                }
1708            \"
1709            makeuserproc userproc-pre-${ident}-${target}-\${proc_index} \$args
1710        "
1711        proc post-$target {args} "
1712            variable proc_index
1713            set proc_index \[llength \[ditem_key $ditem post\]\]
1714            ditem_append $ditem post proc-post-${ident}-${target}-\${proc_index}
1715            proc proc-post-${ident}-${target}-\${proc_index} {name} \"
1716                if {\\\[catch userproc-post-${ident}-${target}-\${proc_index} result\\\]} {
1717                    return -code error \\\$result
1718                } else {
1719                    return 0
1720                }
1721            \"
1722            makeuserproc userproc-post-${ident}-${target}-\${proc_index} \$args
1723        "
1724    }
1725    eval ditem_append $ditem provides $args
1726}
1727
1728proc target_requires {ditem args} {
1729    eval ditem_append $ditem requires $args
1730}
1731
1732proc target_uses {ditem args} {
1733    eval ditem_append $ditem uses $args
1734}
1735
1736proc target_deplist {ditem args} {
1737    eval ditem_append $ditem deplist $args
1738}
1739
1740proc target_prerun {ditem args} {
1741    eval ditem_append $ditem prerun $args
1742}
1743
1744proc target_postrun {ditem args} {
1745    eval ditem_append $ditem postrun $args
1746}
1747
1748proc target_runtype {ditem args} {
1749    eval ditem_append $ditem runtype $args
1750}
1751
1752proc target_state {ditem args} {
1753    eval ditem_append $ditem state $args
1754}
1755
1756proc target_init {ditem args} {
1757    eval ditem_append $ditem init $args
1758}
1759
1760##### variant class #####
1761
1762# constructor for variant objects
1763proc variant_new {name} {
1764    set ditem [ditem_create]
1765    ditem_key $ditem name $name
1766    return $ditem
1767}
1768
1769proc handle_default_variants {option action {value ""}} {
1770    global variations
1771    switch -regex $action {
1772        set|append {
1773            foreach v $value {
1774                if {[regexp {([-+])([-A-Za-z0-9_]+)} $v whole val variant]} {
1775                    if {![info exists variations($variant)]} {
1776                    set variations($variant) $val
1777                    }
1778                }
1779            }
1780        }
1781        delete {
1782            # xxx
1783        }
1784    }
1785}
1786
1787
1788# builds the specified port (looked up in the index) to the specified target
1789# doesn't yet support options or variants...
1790# newworkpath defines the port's workpath - useful for when one port relies
1791# on the source, etc, of another
1792proc portexec_int {portname target {newworkpath ""}} {
1793    ui_debug "Executing $target ($portname)"
1794    set variations [list]
1795    if {$newworkpath == ""} {
1796        array set options [list]
1797    } else {
1798        set options(workpath) ${newworkpath}
1799    }
1800    # Escape regex special characters
1801    regsub -all "(\\(){1}|(\\)){1}|(\\{1}){1}|(\\+){1}|(\\{1}){1}|(\\{){1}|(\\}){1}|(\\^){1}|(\\$){1}|(\\.){1}|(\\\\){1}" $portname "\\\\&" search_string
1802   
1803    set res [mport_search ^$search_string\$]
1804    if {[llength $res] < 2} {
1805        ui_error "Dependency $portname not found"
1806        return -1
1807    }
1808   
1809    array set portinfo [lindex $res 1]
1810    set porturl $portinfo(porturl)
1811    if {[catch {set worker [mport_open $porturl [array get options] $variations]} result]} {
1812        global errorInfo
1813        ui_debug "$errorInfo"
1814        ui_error "Opening $portname $target failed: $result"
1815        return -1
1816    }
1817    if {[catch {mport_exec $worker $target} result] || $result != 0} {
1818        global errorInfo
1819        ui_debug "$errorInfo"
1820        ui_error "Execution $portname $target failed: $result"
1821        mport_close $worker
1822        return -1
1823    }
1824    mport_close $worker
1825   
1826    return 0
1827}
1828
1829# portfile primitive that calls portexec_int with newworkpath == ${workpath}
1830proc portexec {portname target} {
1831    global workpath
1832    return [portexec_int $portname $target $workpath]
1833}
1834
1835proc adduser {name args} {
1836    global os.platform
1837    set passwd {*}
1838    set uid [nextuid]
1839    set gid [existsgroup nogroup]
1840    set realname ${name}
1841    set home /dev/null
1842    set shell /dev/null
1843   
1844    foreach arg $args {
1845        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
1846            regsub -all " " ${val} "\\ " val
1847            set $key $val
1848        }
1849    }
1850   
1851    if {[existsuser ${name}] != 0 || [existsuser ${uid}] != 0} {
1852        return
1853    }
1854   
1855    if {${os.platform} eq "darwin"} {
1856        exec dscl . -create /Users/${name} Password ${passwd}
1857        exec dscl . -create /Users/${name} UniqueID ${uid}
1858        exec dscl . -create /Users/${name} PrimaryGroupID ${gid}
1859        exec dscl . -create /Users/${name} RealName ${realname}
1860        exec dscl . -create /Users/${name} NFSHomeDirectory ${home}
1861        exec dscl . -create /Users/${name} UserShell ${shell}
1862    } else {
1863        # XXX adduser is only available for darwin, add more support here
1864        ui_warn "WARNING: adduser is not implemented on ${os.platform}."
1865        ui_warn "The requested user was not created."
1866    }
1867}
1868
1869proc addgroup {name args} {
1870    global os.platform
1871    set gid [nextgid]
1872    set realname ${name}
1873    set passwd {*}
1874    set users ""
1875   
1876    foreach arg $args {
1877        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
1878            regsub -all " " ${val} "\\ " val
1879            set $key $val
1880        }
1881    }
1882   
1883    if {[existsgroup ${name}] != 0 || [existsgroup ${gid}] != 0} {
1884        return
1885    }
1886   
1887    if {${os.platform} eq "darwin"} {
1888        exec dscl . -create /Groups/${name} Password ${passwd}
1889        exec dscl . -create /Groups/${name} RealName ${realname}
1890        exec dscl . -create /Groups/${name} PrimaryGroupID ${gid}
1891        if {${users} ne ""} {
1892            exec dscl . -create /Groups/${name} GroupMembership ${users}
1893        }
1894    } else {
1895        # XXX addgroup is only available for darwin, add more support here
1896        ui_warn "WARNING: addgroup is not implemented on ${os.platform}."
1897        ui_warn "The requested group was not created."
1898    }
1899}
1900
1901# proc to calculate size of a directory
1902# moved here from portpkg.tcl
1903proc dirSize {dir} {
1904    set size    0;
1905    foreach file [readdir $dir] {
1906        if {[file type [file join $dir $file]] == "link" } {
1907            continue
1908        }
1909        if {[file isdirectory [file join $dir $file]]} {
1910            incr size [dirSize [file join $dir $file]]
1911        } else {
1912            incr size [file size [file join $dir $file]];
1913        }
1914    }
1915    return $size;
1916}
1917
1918# check for a binary in the path
1919# returns an error code if it can not be found
1920proc binaryInPath {binary} {
1921    global env
1922    foreach dir [split $env(PATH) :] { 
1923        if {[file executable [file join $dir $binary]]} {
1924            return [file join $dir $binary]
1925        }
1926    }
1927   
1928    return -code error [format [msgcat::mc "Failed to locate '%s' in path: '%s'"] $binary $env(PATH)];
1929}
1930
1931# Set the UI prefix to something standard (so it can be grepped for in output)
1932proc set_ui_prefix {} {
1933    global UI_PREFIX env
1934    if {[info exists env(UI_PREFIX)]} {
1935        set UI_PREFIX $env(UI_PREFIX)
1936    } else {
1937        set UI_PREFIX "---> "
1938    }
1939}
1940
1941# Use a specified group/version.
1942proc PortGroup {group version} {
1943    global portresourcepath
1944
1945    set groupFile ${portresourcepath}/group/${group}-${version}.tcl
1946
1947    if {[file exists $groupFile]} {
1948        uplevel "source $groupFile"
1949    } else {
1950        ui_warn "Group file could not be located."
1951    }
1952}
1953
1954# check if archive type is supported by current system
1955# returns an error code if it is not
1956proc archiveTypeIsSupported {type} {
1957    global os.platform os.version
1958    set errmsg ""
1959    switch -regex $type {
1960        cp(io|gz) {
1961            set pax "pax"
1962            if {[catch {set pax [binaryInPath $pax]} errmsg] == 0} {
1963                if {[regexp {z$} $type]} {
1964                    set gzip "gzip"
1965                    if {[catch {set gzip [binaryInPath $gzip]} errmsg] == 0} {
1966                        return 0
1967                    }
1968                } else {
1969                    return 0
1970                }
1971            }
1972        }
1973        t(ar|bz|lz|gz) {
1974            set tar "tar"
1975            if {[catch {set tar [binaryInPath $tar]} errmsg] == 0} {
1976                if {[regexp {z2?$} $type]} {
1977                    if {[regexp {bz2?$} $type]} {
1978                        set gzip "bzip2"
1979                    } elseif {[regexp {lz$} $type]} {
1980                        set gzip "lzma"
1981                    } else {
1982                        set gzip "gzip"
1983                    }
1984                    if {[catch {set gzip [binaryInPath $gzip]} errmsg] == 0} {
1985                        return 0
1986                    }
1987                } else {
1988                    return 0
1989                }
1990            }
1991        }
1992        xar {
1993            set xar "xar"
1994            if {[catch {set xar [binaryInPath $xar]} errmsg] == 0} {
1995                return 0
1996            }
1997        }
1998        zip {
1999            set zip "zip"
2000            if {[catch {set zip [binaryInPath $zip]} errmsg] == 0} {
2001                set unzip "unzip"
2002                if {[catch {set unzip [binaryInPath $unzip]} errmsg] == 0} {
2003                    return 0
2004                }
2005            }
2006        }
2007        default {
2008            return -code error [format [msgcat::mc "Invalid port archive type '%s' specified!"] $type]
2009        }
2010    }
2011    return -code error [format [msgcat::mc "Unsupported port archive type '%s': %s"] $type $errmsg]
2012}
2013
2014#
2015# merge function for universal builds
2016#
2017
2018# private function
2019# merge_lipo base-path target-path relative-path architectures
2020# e.g. 'merge_lipo ${workpath}/pre-dest ${destroot} ${prefix}/bin/pstree i386 ppc
2021# will merge binary files with lipo which have to be in the same (relative) path
2022proc merge_lipo {base target file archs} {
2023    set exec-lipo ""
2024    foreach arch ${archs} {
2025        set exec-lipo [concat ${exec-lipo} [list "-arch" "${arch}" "${base}/${arch}${file}"]]
2026    }
2027    set exec-lipo [concat ${exec-lipo}]
2028    system "/usr/bin/lipo ${exec-lipo} -create -output ${target}${file}"
2029}
2030
2031# private function
2032# merge C/C++/.. files
2033# either just copy (if equivalent) or add CPP directive for differences
2034# should work for C++, C, Obj-C, Obj-C++ files and headers
2035proc merge_cpp {base target file archs} {
2036    merge_file $base $target $file $archs
2037    # TODO -- instead of just calling merge_file:
2038    # check if different
2039    #   no: copy
2040    #   yes: merge with #elif defined(__i386__) (__x86_64__, __ppc__, __ppc64__)
2041}
2042
2043# private function
2044# merge_file base-path target-path relative-path architectures
2045# e.g. 'merge_file ${workpath}/pre-dest ${destroot} ${prefix}/share/man/man1/port.1 i386 ppc
2046# will test equivalence of files and copy them if they are the same (for the different architectures)
2047proc merge_file {base target file archs} {
2048    set basearch [lindex ${archs} 0]
2049    ui_debug "ba: '${basearch}' ('${archs}')"
2050    foreach arch [lrange ${archs} 1 end] {
2051        # checking for differences; TODO: error more gracefully on non-equal files
2052        exec "/usr/bin/diff" "-q" "${base}/${basearch}${file}" "${base}/${arch}${file}"
2053    }
2054    ui_debug "ba: '${basearch}'"
2055    file copy "${base}/${basearch}${file}" "${target}${file}"
2056}
2057
2058# merges multiple "single-arch" destroots into the final destroot
2059# 'base' is the path where the different directories (one for each arch) are
2060# e.g. call 'merge ${workpath}/pre-dest' with having a destroot in ${workpath}/pre-dest/i386 and ${workpath}/pre-dest/ppc64 -- single arch -- each
2061proc merge {base} {
2062    global destroot
2063
2064    # test which architectures are available, set one as base-architecture
2065    set archs ""
2066    set base_arch ""
2067    foreach arch {"i386" "x86_64" "ppc" "ppc64"} {
2068        if [file exists "${base}/${arch}"] {
2069            set archs [concat ${archs} ${arch}]
2070            set base_arch ${arch}
2071        }
2072    }
2073    ui_debug "merging architectures ${archs}, base_arch is ${base_arch}"
2074
2075    # traverse the base-architecture directory
2076    set basepath "${base}/${base_arch}"
2077    fs-traverse file "${basepath}" {
2078        set fpath [string range "${file}" [string length "${basepath}"] [string length "${file}"]]
2079        if {${fpath} != ""} {
2080            # determine the type (dir/file/link)
2081            set filetype [exec "/usr/bin/file" "-b" "${basepath}${fpath}"]
2082            switch -regexp ${filetype} {
2083                directory {
2084                    # just create directories
2085                    ui_debug "mrg: directory ${fpath}"
2086                    file mkdir "${destroot}${fpath}"
2087                }
2088                symbolic\ link.* {
2089                    # copy symlinks, TODO: check if targets match!
2090                    ui_debug "mrg: symlink ${fpath}"
2091                    file copy "${basepath}${fpath}" "${destroot}${fpath}"
2092                }
2093                Mach-O.* {
2094                    merge_lipo "${base}" "${destroot}" "${fpath}" "${archs}"
2095                }
2096                current\ ar\ archive {
2097                    merge_lipo "${base}" "${destroot}" "${fpath}" "${archs}"
2098                }
2099                ASCII\ C\ program\ text {
2100                    merge_cpp "${base}" "${destroot}" "${fpath}" "${archs}"
2101                }
2102                default {
2103                    ui_debug "unknown file type: ${filetype}"
2104                    merge_file "${base}" "${destroot}" "${fpath}" "${archs}"
2105                }
2106            }
2107        }
2108    }
2109}
2110
2111##
2112# Escape a string for safe use in regular expressions
2113#
2114# @param str the string to be quoted
2115# @return the escaped string
2116proc quotemeta {str} {
2117    regsub -all {(\W)} $str {\\\1} str
2118    return $str
2119}
2120
Note: See TracBrowser for help on using the repository browser.