source: branches/release_1_6/base/src/port1.0/portutil.tcl

Last change on this file was 33045, checked in by jmpp@…, 10 years ago

Merged revisions 32096-32193,32195-32335,32337-32365,32367-32499,32502-32721,32724-32800,32802-32999 via svnmerge from
http://svn.macports.org/repository/macports/trunk/base

........

r32096 | jmpp@… | 2007-12-16 16:00:13 -0400 (Sun, 16 Dec 2007) | 1 line


Manually merge in 1.6.0 release date into the trunk ChangeLog, off from its branches/release_1_6 guise.

........

r32097 | jmpp@… | 2007-12-16 16:01:50 -0400 (Sun, 16 Dec 2007) | 1 line


Correct a URL to our svn repo.

........

r32100 | jmpp@… | 2007-12-16 18:20:41 -0400 (Sun, 16 Dec 2007) | 5 lines



We only produce tarballs for major releases, which should always come with the "archive" tarballs, so always advise to create them
(with alternate advise on how to not create them).

........

r32101 | jmpp@… | 2007-12-16 19:11:48 -0400 (Sun, 16 Dec 2007) | 7 lines



It makes much more sense to group all three types of checksums for a single tarball together
in the chk file that comes with each release (from the base/Makefile's "distfromsvn" target), as in
{md5,sha1,ripemd160} for tar.gz and then for tar.bz2, rather than all types of tarballs for a single
checksum type, as in {tar.gz,tar.bz2} for md5 and then for sha1 and ripemd160.

........

r32102 | jmpp@… | 2007-12-16 19:24:21 -0400 (Sun, 16 Dec 2007) | 4 lines



Move the UPGRADECHECK abstraction variable into the base/Mk/macports.upgrade.mk where it belongs.

........

r32103 | jmpp@… | 2007-12-16 19:36:49 -0400 (Sun, 16 Dec 2007) | 4 lines



Release 1.6.0 for selfupdate, dmg's will follow.

........

r32105 | jmpp@… | 2007-12-16 21:17:00 -0400 (Sun, 16 Dec 2007) | 9 lines



Pass the generated static cregistry.a archive through ranlib to fix it for universal building,
which is enforced by the MacPorts portfile on Tiger or newer.


This patch will be applied manaully while building the dmg's, since the alternative is merging it
now into the release branch and hence invalidating all the work I've done so far in the release process
(release tag, tarballs, selfupdate, etc...)

........

r32111 | jmpp@… | 2007-12-17 01:20:40 -0400 (Mon, 17 Dec 2007) | 1 line


Whitespace cleanups only, no functional changes. Add modeline.

........

r32113 | jmpp@… | 2007-12-17 01:35:36 -0400 (Mon, 17 Dec 2007) | 4 lines



Explain that resource files in the MacPorts' port's files dir are fetched through svn:externals now.

........

r32114 | jmpp@… | 2007-12-17 01:52:46 -0400 (Mon, 17 Dec 2007) | 7 lines



  • Update checksums instructions for the dmg to output them in the same fashion as we now do for the source tarballs;
  • Include the ${destroot}/opt/local/share/macports/Tcl/registry2.0/registry.dylib library for linking validation when validating the contents of the pkg installer;
  • Add a check for binaries with two architectures when building universal dmg's.

........

r32116 | jmpp@… | 2007-12-17 02:14:28 -0400 (Mon, 17 Dec 2007) | 1 line


More whitespace fixes.

........

r32132 | jmpp@… | 2007-12-17 14:20:49 -0400 (Mon, 17 Dec 2007) | 5 lines



We now have an announcements list (http://lists.macosforge.org/mailman/listinfo/macports-announce/), so use it as such
(also remove the long domain names from this document, we all know them).

........

r32133 | jmpp@… | 2007-12-17 14:22:00 -0400 (Mon, 17 Dec 2007) | 1 line


Remove unnecessary launchd plist, the guide regen job runs as a post-commit hook to the trunk/doc-new directory.

........

r32134 | jmpp@… | 2007-12-17 14:23:09 -0400 (Mon, 17 Dec 2007) | 1 line


Correct comment about the new guide.

........

r32167 | jmpp@… | 2007-12-18 19:11:29 -0400 (Tue, 18 Dec 2007) | 8 lines



  • base/configure.ac: reorder the macros reading our version number from the base/config/mp_version file, export MP_VERSION (It would be great to figure out how to use the result of $MP_VERSION in AC_INIT, to avoid the code duplication that's

present with the esyscmd command);

  • configure: regen;
  • base/src/macports1.0/macports_autoconf.tcl.in: save the MacPorts version number in the macports1.0 namespace as macports_version.

........

r32169 | jmpp@… | 2007-12-18 19:53:32 -0400 (Tue, 18 Dec 2007) | 4 lines



Use the new $macports::autoconf::macports_version variable to get our own version and remove some now unnecessary code.

........

r32170 | jmpp@… | 2007-12-18 20:17:14 -0400 (Tue, 18 Dec 2007) | 4 lines



Simplify the macports::version proc by use of the $macports::autoconf::macports_version variable (also remove some globals that weren't necessary in any case).

........

r32172 | jmpp@… | 2007-12-18 20:47:53 -0400 (Tue, 18 Dec 2007) | 1 line


Whitespace cleanup.

........

r32202 | jmpp@… | 2007-12-19 17:29:34 -0400 (Wed, 19 Dec 2007) | 1 line


Add sourceforge to our list of 3rd party sites we submit our downloads to, reorder other site entries a bit.

........

r32206 | wsiegrist@… | 2007-12-19 20:31:31 -0400 (Wed, 19 Dec 2007) | 1 line


generalized script to /tmp/mpdocs instead of /Users/... Also removed any PATH assumptions. Added MacOSForge sysadmin to the mail address list.

........

r32208 | jmpp@… | 2007-12-20 04:20:37 -0400 (Thu, 20 Dec 2007) | 1 line


Whitespace cleanups.

........

r32209 | jmpp@… | 2007-12-20 04:27:05 -0400 (Thu, 20 Dec 2007) | 1 line


Simple whitespace fix.

........

r32210 | jmpp@… | 2007-12-20 04:30:45 -0400 (Thu, 20 Dec 2007) | 1 line


Whitespace cleanups.

........

r32212 | jmpp@… | 2007-12-20 04:45:23 -0400 (Thu, 20 Dec 2007) | 8 lines



When building on Panther, the new registry sources (cregistry and registry2.0) fail 'cause there's no sqlite3
on that platform. In this case we build with our bundled sqlite3, so if we're doing that go ahead and append
a "-I../sqlite-3.1.3" rule to our includes search path, so that sqlite3 headers are found.


Maun Suang, can you please try building trunk + this patch on Panther?

........

r32223 | jmpp@… | 2007-12-20 15:53:51 -0400 (Thu, 20 Dec 2007) | 5 lines



Rename the $mp_base_path variable to $mp_source_path in the selfupdate proc, to make its intent clearer from its name.
Also change a debug comment accordingly.

........

r32224 | jmpp@… | 2007-12-20 16:02:53 -0400 (Thu, 20 Dec 2007) | 4 lines



Another variable rename, no functional changes: $mp_version_new to $macports_version_new, to match the naming of $macports::autoconf::macports_version.

........

r32353 | jmpp@… | 2007-12-27 03:35:22 -0400 (Thu, 27 Dec 2007) | 12 lines



$(find . -type f \! -path "*.svn/*" | xargs grep -nH mp_version) assures me nothing else but macports::selfupdate and macports::version
reads the ${prefix}/etc/macports/mp_version installed file, and I've already taken care of those to to read $macports::autoconf::macports_version
for our version number instead, so let's not install the base/config/mp_version file anymore.


Note that base/config/mp_version cannot disappear from svn, though, as that's what's read by macports::selfupdate to determine if the
selfupdate'd sources are newer than what's installed.


BRAINSTORM: After this commit, the ${prefix}/etc/macports/mp_version installed file is going to stall and thus might confuse people,
so should we delete it upon installing a new release?

........

r32354 | jmpp@… | 2007-12-27 03:36:48 -0400 (Thu, 27 Dec 2007) | 1 line


Grammar++

........

r32363 | jmpp@… | 2007-12-27 15:03:53 -0400 (Thu, 27 Dec 2007) | 7 lines



Delete the base/config/dp_version file as a sort of stealth test: only pre dp2mp-move sources use it
and will not be able to selfupdate without it (but don't worry, the problem is easily solved by forcing
the selfupdate through port(1)'s -f flag). The number of complaints we get about a missing dp_version file
will give us a hint about how many out there are still using pre dp2mp-move MacPorts releases (if small,
we might be able to remove all the related upgrade code).

........

r32364 | jmpp@… | 2007-12-27 16:07:33 -0400 (Thu, 27 Dec 2007) | 13 lines



Don't use plain arithmetical comparison to determine if the downloaded sources are newer than the installed MacPorts,
but rather our own rpm-vercomp to compare $macports_version_new against $macports::autoconf::macports_version.
As of this moment, the result is the same (and will be the same when we release 1.xyz, with x > 6 and/or y,z > 0)
as the arithmetical comparison, but in the future this change will allow us to introduce real version numbers into
MacPorts.


My current idea is to create a base/config/macports_version file holding something like 1.6.1, but the selfupdate
logic of reading the latter over base/config/mp_version has to be thoroughly thought out: 600 (from base/config/mp_version's 1.600)
is greater than 6, so if we flat out select base/config/macports_version to read the new version we will break
selfupdating for everyone, as rpm-vercomp will not see 1.6.1 as greater than 1.600.

........

r32365 | jmpp@… | 2007-12-27 16:31:52 -0400 (Thu, 27 Dec 2007) | 11 lines



Add the base/config/macports_version file holding the 1.7.0 version number (for trunk), with limited usage for the time being:


  • Read it in for the autoconf @MACPORTS_VERSION@ variable;
  • Stop the Snoopy talk in configure.ac to convert the floating point format to a regular versions, reading base/config/macports_version directly instead;
  • Switch files with @VER@ substitution over to @MACPORTS_VERSION@.


The $macports::autoconf::macports_version will still read from @MP_VERSION@, the floating point format,
until a good logic for selfupdate magically emerges (cf. r32364).

........

r32394 | jmpp@… | 2007-12-29 00:43:49 -0400 (Sat, 29 Dec 2007) | 16 lines



A thoroughly rewritten selfupdate proc:


  • steps now happen in a more logical order: first we sync the ports tree, then the base sources, then see if we're being forced or if we're using version numbers to discern upgrading or not and, lastly, we rebuild accordingly;
  • the above reordering allows us to force the selfupdate to get around no rsync'd version file being found for whatever reason; previously such event would lead to a situation in which not even forcing would help, affected users had to grab the dmg or rebuild from source manually;
  • in case we're not being forced, choose between two rsync'd version files: the old, floating point format (mp_version) or the new, real version number format (macports_version); we're still using the old one (cf. r32364), but when we release something like 2.0.0 we'll switch to the new one;
  • improved MacPorts installation owner detection and setting upon reinstallation: we now read ${prefix}'s attributes;
  • ${prefix} permissions are now also preserved across selfupdates (REMINDER: this should be a NEWS & ChangeLog entry);
  • renamed some variables to clearer names;
  • improved many informational and debug messages and in-source comments.

........

r32395 | jmpp@… | 2007-12-29 01:08:23 -0400 (Sat, 29 Dec 2007) | 4 lines



Remove the ${sysconfdir}/macports/mp_version file prior to reinstalling MacPorts, as its installation is now deprecated.

........

r32396 | jmpp@… | 2007-12-29 01:17:25 -0400 (Sat, 29 Dec 2007) | 6 lines



Include my r32395 deletion of the /opt/local/etc/macports/mp_version file deletion into the preflight script of the pkg, for future major version releases.
Note that this is not the best place to put this rule, as currently preflight takes care of the dp2mp-move for the pkg installer and they are orthogonal sets
of upgrading rules..., but I simply don't know of anywhere else to put this one so that it is performed when installing from the pkg.

........

r32397 | jmpp@… | 2007-12-29 01:29:39 -0400 (Sat, 29 Dec 2007) | 8 lines



Some syntax tweaks:


  • we're using bash, to use echo's -e flag and remove useless echo calls for newline characters;
  • whitespace cleanups;
  • remove useless semicolons.

........

r32398 | jmpp@… | 2007-12-29 01:37:39 -0400 (Sat, 29 Dec 2007) | 1 line


Whitespace cleanups.

........

r32430 | afb@… | 2007-12-31 06:19:09 -0400 (Mon, 31 Dec 2007) | 1 line


make configure.pipe hackable from Portfiles too (#13636)

........

r32441 | jberry@… | 2008-01-01 12:39:21 -0430 (Tue, 01 Jan 2008) | 4 lines


If checksum is mismatched, and in verbose mode, present a corrected pre-fabricated
checksum statement to make it easy to update a port.

........

r32480 | afb@… | 2008-01-04 05:15:34 -0430 (Fri, 04 Jan 2008) | 1 line


recognize non-canonical modelines (#13496)

........

r32514 | eridius@… | 2008-01-05 20:50:25 -0430 (Sat, 05 Jan 2008) | 1 line


Replace the ui_channels if statement with a try-catch to try and fix the mysterious 10.3 issue

........

r32525 | eridius@… | 2008-01-06 18:08:34 -0430 (Sun, 06 Jan 2008) | 1 line


Change the ui_prefix if-else block to a try-catch block

........

r32526 | ryandesign@… | 2008-01-06 18:44:15 -0430 (Sun, 06 Jan 2008) | 1 line


fix typo in comment

........

r32537 | jmpp@… | 2008-01-07 05:31:03 -0430 (Mon, 07 Jan 2008) | 5 lines



Simplify the test that errors out if we're not selfupdating with the needed power: bail out right away if $installing_user doesn't own ${prefix}.
Also improve some of the comments we output.

........

r32541 | eridius@… | 2008-01-07 14:58:25 -0430 (Mon, 07 Jan 2008) | 1 line


Tweak autoconf scripts to avoid duplication of the shell stuff to read macports_version

........

r32542 | jmpp@… | 2008-01-07 15:17:37 -0430 (Mon, 07 Jan 2008) | 7 lines



Move all autoconf macros files into a dedicated m4 directory, adapting aclocal.m4 to load them
from their new home (but leaving the latter right next to configure.ac, as otherwise the loading
paths become a bit cumbersome -- even though aclocal.m4 can indeed be moved into the base/m4/
directory).

........

r32543 | jmpp@… | 2008-01-07 15:24:26 -0430 (Mon, 07 Jan 2008) | 4 lines


Add svn:eol-style to all autoconf m4 macros files, remove the Id keyword from base/m4/tcl.m4 as we're probably not meant to be touching it in any case.
Use $Id$ in aclocal.m4.

........

r32544 | eridius@… | 2008-01-07 16:03:17 -0430 (Mon, 07 Jan 2008) | 2 lines


Fix permissions code in selfupdate.
Change from /usr/bin/whoami to /usr/bin/id -un as whoami is deprecated

........

r32546 | jmpp@… | 2008-01-07 16:44:11 -0430 (Mon, 07 Jan 2008) | 5 lines



If selfupdate is forced, the setting of the $macports_version_new var is skipped, so the if {[rpm-vercomp $macports_version_new $macports::autoconf::macports_version] > 0 || $use_the_force_luke == "yes"}
test fails because the $macports_version_new variable is not defined. Swap the two tests in the if clause so that we can short circuit around the second one and thus not fail if forcing is requested.

........

r32549 | jmpp@… | 2008-01-07 18:20:38 -0430 (Mon, 07 Jan 2008) | 4 lines


Tweak the visual aspect of the selfupdate output yet again, updating the documentation URLs we hand off to users through the main base/Makefile
(mentioning our new guide).

........

r32597 | jmpp@… | 2008-01-08 17:29:50 -0430 (Tue, 08 Jan 2008) | 4 lines



Add a README file that explains how our server side jobs work and when (how often).

........

r32598 | jmpp@… | 2008-01-08 17:31:22 -0430 (Tue, 08 Jan 2008) | 1 line


Little rewording.

........

r32600 | jmpp@… | 2008-01-08 17:43:07 -0430 (Tue, 08 Jan 2008) | 1 line


Itemize binaries that need linking verification when building the dmg, for better readability.

........

r32605 | jmpp@… | 2008-01-08 23:22:37 -0430 (Tue, 08 Jan 2008) | 4 lines



The start of the documentation of the potential chanegs that will go into the 1.6.1 release.

........

r32606 | jmpp@… | 2008-01-08 23:23:50 -0430 (Tue, 08 Jan 2008) | 1 line


Add the svn:eol-style keyword to the NEWS file.

........

r32615 | ryandesign@… | 2008-01-09 05:09:51 -0430 (Wed, 09 Jan 2008) | 1 line


typos and hyphenation

........

r32631 | boeyms@… | 2008-01-10 01:26:22 -0430 (Thu, 10 Jan 2008) | 2 lines


portmgr/ReleaseProcess: add note that daemondo is not built on Panther and so does not need checking.

........

r32720 | afb@… | 2008-01-12 05:56:59 -0430 (Sat, 12 Jan 2008) | 1 line


make sure install depends on scripts

........

r32721 | afb@… | 2008-01-12 06:04:00 -0430 (Sat, 12 Jan 2008) | 4 lines


  • Sort in NVR (name@version_revision) order (#13031)
  • currently resorts the "port installed" list, it was showing in string order even ::installed was sorted?

........

r32724 | afb@… | 2008-01-12 07:39:50 -0430 (Sat, 12 Jan 2008) | 1 line


port platform, info target (#12302)

........

r32725 | eridius@… | 2008-01-12 10:41:57 -0430 (Sat, 12 Jan 2008) | 1 line


Teach port info that depends_run is a list

........

r32741 | ryandesign@… | 2008-01-12 18:27:57 -0430 (Sat, 12 Jan 2008) | 1 line


add archive to apache mirror sites so older versions of things can still be downloaded; fixes #13891

........

r32821 | jmpp@… | 2008-01-13 23:08:58 -0430 (Sun, 13 Jan 2008) | 5 lines



Follow the proper error reporting procedure if stale lock files are found (put together a mail and send it to the people in charge),
don't just exit with an error line to the console as that can be easily lost.

........

r32822 | wsiegrist@… | 2008-01-13 23:17:01 -0430 (Sun, 13 Jan 2008) | 1 line


removing dluke from error emails per his request

........

r32824 | eridius@… | 2008-01-13 23:49:33 -0430 (Sun, 13 Jan 2008) | 1 line


Add our version to the User-Agent in libcurl

........

r32832 | jmpp@… | 2008-01-14 00:36:34 -0430 (Mon, 14 Jan 2008) | 1 line


Whitespace fix.

........

r32893 | jmpp@… | 2008-01-14 11:04:44 -0430 (Mon, 14 Jan 2008) | 1 line


Use new variable names controling our website.

........

r32999 | afb@… | 2008-01-16 08:25:44 -0430 (Wed, 16 Jan 2008) | 1 line


update changelog for r32194 and r32724

........

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