source: branches/variant-descs-14482/base/src/port1.0/portutil.tcl @ 40953

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

Merged revisions 38101-38102,38107,38109,38114-38115,38163,38230,38232,38252,38255,38271,38304,38315-38317,38331-38332,38344,38495-38497,38506,38556-38557,38577,38683-38684,38753,38756,38765,38835,38883,38940-38942,38960-38961,38973,39012,39016-39017,39021,39023,39025,39036,39116,39177,39257,39564,39573,39990,40051-40061,40142,40159,40387,40414,40445,40450,40475-40476,40693,40712,40729,40803,40824,40834,40836,40894,40906,40952 via svnmerge from
https://svn.macports.org/repository/macports/trunk/base

........

r38101 | raimue@… | 2008-07-06 18:41:47 +0200 (Sun, 06 Jul 2008) | 3 lines


doc/Makefile:
gzip man pages on make all

........

r38102 | raimue@… | 2008-07-06 18:43:33 +0200 (Sun, 06 Jul 2008) | 3 lines


doc:
Ignore generated gzipped man pages

........

r38107 | raimue@… | 2008-07-06 20:49:40 +0200 (Sun, 06 Jul 2008) | 3 lines


Makefile.in:
Remove Doxyfile on distclean

........

r38109 | raimue@… | 2008-07-06 22:27:48 +0200 (Sun, 06 Jul 2008) | 5 lines


base:
Add a new setupenv.sh script which can be used to setup the environment for
MacPorts. It will be installed to ${prefix}/share/macports/setupenv.sh and can
be sourced from your profile.

........

r38114 | raimue@… | 2008-07-07 02:38:32 +0200 (Mon, 07 Jul 2008) | 3 lines


base:
Rename setupenv.sh to setupenv.bash to reflect that it is for bash only

........

r38115 | raimue@… | 2008-07-07 03:00:40 +0200 (Mon, 07 Jul 2008) | 3 lines


setupenv.bash.in:
Set svn:keywords=Id and svn:eol-style=native

........

r38163 | jmr@… | 2008-07-10 03:50:57 +0200 (Thu, 10 Jul 2008) | 2 lines


In fetch, gracefully handle failure to spawn ping processes. (#15906)

........

r38230 | raimue@… | 2008-07-13 12:06:54 +0200 (Sun, 13 Jul 2008) | 3 lines


port/port.tcl:
Exit gracefully if an invalid global option was given

........

r38232 | jmr@… | 2008-07-13 12:25:29 +0200 (Sun, 13 Jul 2008) | 2 lines


Mirror sites: add new transact SourceForge mirror

........

r38252 | raimue@… | 2008-07-13 23:40:06 +0200 (Sun, 13 Jul 2008) | 3 lines


doc/port.1:
Document 'port edit --editor'

........

r38255 | raimue@… | 2008-07-14 00:38:40 +0200 (Mon, 14 Jul 2008) | 4 lines


port/port.tcl:
Convert list to string to allow additional parameters,
for example port edit --editor 'vim -y'

........

r38271 | mww@… | 2008-07-14 16:29:47 +0200 (Mon, 14 Jul 2008) | 3 lines


add 'llvm-gcc-4.2' compiler suite (from XCode 3.1);
make a wild guess at default compiler choice for 10.6;

........

r38304 | raimue@… | 2008-07-15 07:33:22 +0200 (Tue, 15 Jul 2008) | 6 lines


port1.0/portconfigure.tcl:
Add a new command 'use_autoreconf'
This can replace instances of 'system' in our Portfiles, especially when a port
runs any combination of aclocal/autoconf/automake/, as autoreconf automatically
figures out what needs to be run.

........

r38315 | ryandesign@… | 2008-07-15 11:38:03 +0200 (Tue, 15 Jul 2008) | 2 lines


portbuild.tcl: simplify port output by no longer showing the build target; closes #15881

........

r38316 | ryandesign@… | 2008-07-15 11:44:14 +0200 (Tue, 15 Jul 2008) | 2 lines


ChangeLog: Note fix for #15881

........

r38317 | jmr@… | 2008-07-15 14:47:07 +0200 (Tue, 15 Jul 2008) | 2 lines


Don't use quotes when setting MACOSX_DEPLOYMENT_TARGET in the env_array, for consistency

........

r38331 | jmr@… | 2008-07-16 07:35:46 +0200 (Wed, 16 Jul 2008) | 2 lines


ChangeLog: distfiles mirror is added to patch_sites too

........

r38332 | jmr@… | 2008-07-16 07:47:24 +0200 (Wed, 16 Jul 2008) | 2 lines


ChangeLog: note the fix for the case-sensitive deactivate bug (#11759)

........

r38344 | raimue@… | 2008-07-16 17:00:40 +0200 (Wed, 16 Jul 2008) | 4 lines


Makefile.in:
Added the install line for setupenv.bash at the wrong place which prevented
install to complete due to a missing directory.

........

r38495 | wsiegrist@… | 2008-07-22 20:09:32 +0200 (Tue, 22 Jul 2008) | 2 lines


Add checks to cleanup exports leftover from failed mprsyncup runs

........

r38496 | wsiegrist@… | 2008-07-22 20:36:55 +0200 (Tue, 22 Jul 2008) | 2 lines


Updating jobs scripts from servers: Use a more appropriate tmp dir

........

r38497 | wsiegrist@… | 2008-07-22 20:40:15 +0200 (Tue, 22 Jul 2008) | 2 lines


Adding scripts used on the servers for mirroring during post-commit and daily

........

r38506 | rhwood@… | 2008-07-23 11:43:14 +0200 (Wed, 23 Jul 2008) | 7 lines


Armahg's patch to macports::ui_init for the GSOC08 frameworks project.


This patch allows users of the Tcl API for MacPorts to define custom ui_*
procedures message handling mechanisms.


Closes #15913, committing per email and IRC conversation.

........

r38556 | ryandesign@… | 2008-07-25 08:58:30 +0200 (Fri, 25 Jul 2008) | 2 lines


portbuild.tcl: allow parallel builds for scons too, not just for make

........

r38557 | ryandesign@… | 2008-07-25 09:06:16 +0200 (Fri, 25 Jul 2008) | 2 lines


ChangeLog: note parallel build support for scons-based ports in r38556

........

r38577 | afb@… | 2008-07-25 11:44:33 +0200 (Fri, 25 Jul 2008) | 2 lines


don't use build.nice for creative build.cmd lines (#16091)

........

r38683 | febeling@… | 2008-07-28 23:21:33 +0200 (Mon, 28 Jul 2008) | 9 lines


Support for ruby19 ports in the ruby port group.


The command ruby.setup accepts an new optional
parameter "implementation", which is ruby18 by
default, and can also be ruby19. (As more ruby
implementations appear these may be added as
well.) Unit tests are in the new sub-directory
tests/.

........

r38684 | febeling@… | 2008-07-28 23:32:47 +0200 (Mon, 28 Jul 2008) | 2 lines


ChangeLog for ruby group change, #15912.

........

r38753 | afb@… | 2008-07-30 09:30:39 +0200 (Wed, 30 Jul 2008) | 2 lines


update changelog for r38577

........

r38756 | afb@… | 2008-07-30 12:13:23 +0200 (Wed, 30 Jul 2008) | 2 lines


unbreak test case when ruby19 is not installed or not running leopard

........

r38765 | toby@… | 2008-07-30 21:59:14 +0200 (Wed, 30 Jul 2008) | 2 lines


fix distclean

........

r38835 | febeling@… | 2008-08-01 10:47:58 +0200 (Fri, 01 Aug 2008) | 2 lines


remove hard-coded mp prefix in test case setup

........

r38883 | wsiegrist@… | 2008-08-02 01:53:41 +0200 (Sat, 02 Aug 2008) | 2 lines


Make the guide chunkier at <http://guide.macports.org/chunked/>

........

r38940 | raimue@… | 2008-08-03 10:05:42 +0200 (Sun, 03 Aug 2008) | 4 lines


pextlib1.0:
Add a wrapper for isatty(3). Add term_get_size to find the size of a connected
terminal for a channel using ioctl(2).

........

r38941 | raimue@… | 2008-08-03 10:10:26 +0200 (Sun, 03 Aug 2008) | 4 lines


port/port.tcl:
Use isatty and term_get_size from pextlib to determine the size of the
connected terminal. This requires the Pextlib package.

........

r38942 | raimue@… | 2008-08-03 10:19:05 +0200 (Sun, 03 Aug 2008) | 3 lines


pextlib1.0/tty.c:
Tabs to spaces

........

r38960 | afb@… | 2008-08-04 11:23:00 +0200 (Mon, 04 Aug 2008) | 2 lines


add use_lzma for .tar.lzma support

........

r38961 | afb@… | 2008-08-04 11:29:00 +0200 (Mon, 04 Aug 2008) | 2 lines


fix typo

........

r38973 | jmr@… | 2008-08-04 18:11:28 +0200 (Mon, 04 Aug 2008) | 2 lines


mirror sites: order sourceforge mirrors more or less geographically

........

r39012 | jmr@… | 2008-08-06 08:56:11 +0200 (Wed, 06 Aug 2008) | 2 lines


Fix invalid DOCTYPE in generated launchd .plists. Thanks to blb for the patch. Closes #16200.

........

r39016 | afb@… | 2008-08-06 09:42:34 +0200 (Wed, 06 Aug 2008) | 2 lines


work around Leopard Tcl bugs (#16010)

........

r39017 | afb@… | 2008-08-06 09:46:08 +0200 (Wed, 06 Aug 2008) | 2 lines


work around Leopard Tcl bugs (#16233)

........

r39021 | afb@… | 2008-08-06 09:53:18 +0200 (Wed, 06 Aug 2008) | 2 lines


update changelog

........

r39023 | ryandesign@… | 2008-08-06 10:00:26 +0200 (Wed, 06 Aug 2008) | 2 lines


ChangeLog: consolidate entries for Leopard environment variable issue

........

r39025 | ryandesign@… | 2008-08-06 10:36:18 +0200 (Wed, 06 Aug 2008) | 2 lines


portlint.tcl, portutil.tcl: undo changes inadvertently committed in r39023

........

r39036 | raimue@… | 2008-08-06 15:56:52 +0200 (Wed, 06 Aug 2008) | 4 lines


port/port.tcl:
In 'port gohome', use homepage variable from PortIndex if available. Otherwise
read it from the Portfile. This way, this command works faster. Closes #16146.

........

r39116 | jmr@… | 2008-08-08 18:12:16 +0200 (Fri, 08 Aug 2008) | 2 lines


Add clean_dep_map proc to registry, for removing duplicate dependency entries. (See #8763)

........

r39177 | simon@… | 2008-08-11 14:22:33 +0200 (Mon, 11 Aug 2008) | 2 lines


base: Typo fix in portfetch.tcl.

........

r39257 | afb@… | 2008-08-14 15:05:43 +0200 (Thu, 14 Aug 2008) | 2 lines


add new primary category: office (#16311)

........

r39564 | ryandesign@… | 2008-08-25 07:06:35 +0200 (Mon, 25 Aug 2008) | 2 lines


gcc-dp-* was renamed to gcc-mp-* quite some time ago

........

r39573 | raimue@… | 2008-08-25 19:18:20 +0200 (Mon, 25 Aug 2008) | 3 lines


port1.0/portconfigure.tcl:
Return an error if an invalid value was given to configure.compiler

........

r39990 | ryandesign@… | 2008-09-16 00:54:08 +0200 (Tue, 16 Sep 2008) | 2 lines


PortIndexRegen.sh: fix typo in comment

........

r40051 | toby@… | 2008-09-19 04:08:13 +0200 (Fri, 19 Sep 2008) | 2 lines


fix warnings

........

r40052 | toby@… | 2008-09-19 04:08:41 +0200 (Fri, 19 Sep 2008) | 2 lines


eliminate some -Wformat-security issues

........

r40053 | toby@… | 2008-09-19 04:12:52 +0200 (Fri, 19 Sep 2008) | 2 lines


another -Wformat-security fix

........

r40054 | toby@… | 2008-09-19 04:22:41 +0200 (Fri, 19 Sep 2008) | 2 lines


fix typecasts

........

r40055 | toby@… | 2008-09-19 04:33:48 +0200 (Fri, 19 Sep 2008) | 3 lines


Prefer -UTF8String over long-deprecated -cString.
Eliminate a format string issue.

........

r40056 | toby@… | 2008-09-19 04:42:46 +0200 (Fri, 19 Sep 2008) | 2 lines


Stop setting MACOSX_DEPLOYMENT_TARGET

........

r40057 | toby@… | 2008-09-19 04:49:56 +0200 (Fri, 19 Sep 2008) | 2 lines


-framework Foundation is meaningless when compiling, don't include in CFLAGS

........

r40058 | toby@… | 2008-09-19 04:53:51 +0200 (Fri, 19 Sep 2008) | 2 lines


another typecast fix

........

r40059 | toby@… | 2008-09-19 05:14:25 +0200 (Fri, 19 Sep 2008) | 2 lines


Somewhat ugly hack to eliminate PACKAGE_* warning spam.

........

r40060 | toby@… | 2008-09-19 05:20:22 +0200 (Fri, 19 Sep 2008) | 2 lines


handle _ in arch name (x86_64)

........

r40061 | toby@… | 2008-09-19 05:26:27 +0200 (Fri, 19 Sep 2008) | 2 lines


more warning fixes

........

r40142 | jmr@… | 2008-09-22 12:43:46 +0200 (Mon, 22 Sep 2008) | 2 lines


Run a script in 'make install' and .dmg postflight which removes any duplicate entries from the dep_map (#8763)

........

r40159 | jmr@… | 2008-09-23 03:12:18 +0200 (Tue, 23 Sep 2008) | 2 lines


Run dep_map_clean.tcl *after* installing, so it works on new installs.

........

r40387 | jmpp@… | 2008-09-30 09:35:42 +0200 (Tue, 30 Sep 2008) | 8 lines



It doesn't really matter as we don't have any Portfiles with non-ascii characters, as far as I've been able to see...
But stil, since we operate fully on utf8 mode when reading the Portfiles, we might as well store them as such in the db.


PS: As far as I'm aware, changes to this script require manual reinstallation, as our Makefiles don't install it by default.
PSS: Once reinstalled and the new, fully utf8 tables have been created, a "mysql_set_charset('utf8',$portsdb_connection);"
instruction would be appropriate in the else block of the portsdb_connect() function in trunk/www/includes/common.inc.

........

r40414 | raimue@… | 2008-10-01 04:53:38 +0200 (Wed, 01 Oct 2008) | 4 lines


port/port.tcl:
Quote homepage URL to avoid problems with special shell characters like '&'.
Closes #16491

........

r40445 | febeling@… | 2008-10-02 10:02:08 +0200 (Thu, 02 Oct 2008) | 2 lines


portlint.tcl: add erlang primary category

........

r40450 | macsforever2000@… | 2008-10-02 15:13:44 +0200 (Thu, 02 Oct 2008) | 2 lines


Added finance and gis as primary categories.

........

r40475 | toby@… | 2008-10-02 23:11:13 +0200 (Thu, 02 Oct 2008) | 2 lines


s/Keven/Kevin/

........

r40476 | toby@… | 2008-10-02 23:12:32 +0200 (Thu, 02 Oct 2008) | 3 lines


Include stdint.h to correctly get intptr_t.
Fixes #16718

........

r40693 | raimue@… | 2008-10-11 01:35:39 +0200 (Sat, 11 Oct 2008) | 4 lines


port/port.tcl:
Fix 'port cat'; A newline was always appended on the end of the file and there
was a problem with files larger than 4096 bytes. Closes #16817

........

r40712 | raimue@… | 2008-10-12 04:53:54 +0200 (Sun, 12 Oct 2008) | 4 lines


base:
Inheritance of macports.conf, patch by Adam Byrtek
Closes #16329

........

r40729 | jmr@… | 2008-10-13 01:37:22 +0200 (Mon, 13 Oct 2008) | 2 lines


Make 'port deps' show the correct dependencies when variants are given. (#11891)

........

r40803 | jmr@… | 2008-10-15 12:17:48 +0200 (Wed, 15 Oct 2008) | 2 lines


Move default frameworks_dir under prefix, and use it in portgroups

........

r40824 | nox@… | 2008-10-15 18:35:54 +0200 (Wed, 15 Oct 2008) | 2 lines


Fixed a bug introduced in r40803, variables were not imported in the proc scope.

........

r40834 | jmr@… | 2008-10-16 01:25:40 +0200 (Thu, 16 Oct 2008) | 2 lines


Fix _libtest breakage introduced in r40803 (#16877)

........

r40836 | toby@… | 2008-10-16 03:32:21 +0200 (Thu, 16 Oct 2008) | 2 lines


support platform releases with multiple versions, because nine plus one is ten

........

r40894 | simon@… | 2008-10-17 15:33:45 +0200 (Fri, 17 Oct 2008) | 2 lines


base: Add support to fetch using Mercurial.

........

r40906 | ryandesign@… | 2008-10-18 01:18:28 +0200 (Sat, 18 Oct 2008) | 2 lines


mirror_sites.tcl: remove stale ftp.uu.net mirror; see http://lists.macosforge.org/pipermail/macports-dev/2008-October/006191.html

........

r40952 | blb@… | 2008-10-19 01:37:46 +0200 (Sun, 19 Oct 2008) | 2 lines


Fix unarchive using xar, #16806

........

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