source: trunk/base/src/darwinports1.0/darwinports.tcl @ 2086

Last change on this file since 2086 was 2086, checked in by kevin, 18 years ago

Don't build the target port twice.

  • Property svn:eol-style set to native
File size: 14.9 KB
Line 
1#!/usr/bin/env tclsh8.3
2# darwinports.tcl
3#
4# Copyright (c) 2002 Apple Computer, Inc.
5# All rights reserved.
6#
7# Redistribution and use in source and binary forms, with or without
8# modification, are permitted provided that the following conditions
9# are met:
10# 1. Redistributions of source code must retain the above copyright
11#    notice, this list of conditions and the following disclaimer.
12# 2. Redistributions in binary form must reproduce the above copyright
13#    notice, this list of conditions and the following disclaimer in the
14#    documentation and/or other materials provided with the distribution.
15# 3. Neither the name of Apple Computer, Inc. nor the names of its contributors
16#    may be used to endorse or promote products derived from this software
17#    without specific prior written permission.
18#
19# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
20# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
21# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
22# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
23# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
24# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
25# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
26# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
27# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
28# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
29# POSSIBILITY OF SUCH DAMAGE.
30#
31package provide darwinports 1.0
32package require darwinports_dlist 1.0
33
34namespace eval darwinports {
35    namespace export bootstrap_options portinterp_options open_dports
36    variable bootstrap_options "portdbpath libpath auto_path sources_conf prefix"
37    variable portinterp_options "portdbpath portpath auto_path prefix portsharepath"
38       
39        variable open_dports {}
40}
41
42# Provided UI instantiations
43# For standard messages, the following priorities are defined
44#     debug, info, msg, warn, error
45# Clients of the library are expected to provide ui_puts with the following prototype:
46#     proc ui_puts {priority string nonl}
47# ui_puts should handle the above defined priorities
48
49proc ui_debug {str {nonl ""}} {
50    ui_puts debug "$str" $nonl
51}
52
53proc ui_info {str {nonl ""}} {
54    ui_puts info "$str" $nonl
55}
56
57proc ui_msg {str {nonl ""}} {
58    ui_puts msg "$str" $nonl
59}
60
61proc ui_error {str {nonl ""}} {
62    ui_puts error "$str" $nonl
63}
64
65proc ui_warn {str {nonl ""}} {
66    ui_puts warn "$str" $nonl
67}
68
69proc dportinit {args} {
70    global auto_path env darwinports::portdbpath darwinports::bootstrap_options darwinports::portinterp_options darwinports::portconf darwinports::sources darwinports::sources_conf darwinports::portsharepath
71
72    if {[llength [array names env HOME]] > 0} {
73        set HOME [lindex [array get env HOME] 1]
74        if [file isfile [file join ${HOME} .portsrc]] {
75            set portconf [file join ${HOME} .portsrc]
76            lappend conf_files ${portconf}
77        }
78    }
79
80    if {![info exists portconf] && [file isfile /etc/ports/ports.conf]} {
81        set portconf /etc/ports/ports.conf
82        lappend conf_files /etc/ports/ports.conf
83    }
84    if [info exists conf_files] {
85        foreach file $conf_files {
86            set fd [open $file r]
87            while {[gets $fd line] >= 0} {
88                foreach option $bootstrap_options {
89                    if {[regexp "^$option\[ \t\]+(\[A-Za-z0-9\./\]+$)" $line match val] == 1} {
90                        set darwinports::$option $val
91                        global darwinports::$option
92                    }
93                }
94            }
95        }
96    }
97
98    if {![info exists sources_conf]} {
99        return -code error "sources_conf must be set in /etc/ports/ports.conf or in your .portsrc"
100    }
101    if {[catch {set fd [open $sources_conf r]} result]} {
102        return -code error "$result"
103    }
104    while {[gets $fd line] >= 0} {
105        if ![regexp {[\ \t]*#.*|^$} $line] {
106            lappend sources $line
107        }
108    }
109    if ![info exists sources] {
110        if [file isdirectory dports] {
111            set sources "file://[pwd]/dports"
112        } else {
113            return -code error "No sources defined in $sources_conf"
114        }
115    }
116
117    if ![info exists portdbpath] {
118        return -code error "portdbpath must be set in /etc/ports/ports.conf or in your ~/.portsrc"
119    }
120    if ![file isdirectory $portdbpath] {
121        if ![file exists $portdbpath] {
122            if {[catch {file mkdir $portdbpath} result]} {
123                return -code error "portdbpath $portdbpath does not exist and could not be created: $result"
124            }
125        }
126    }
127    if ![file isdirectory $portdbpath] {
128        return -code error "$portdbpath is not a directory. Please create the directory $portdbpath and try again"
129    }
130
131    set portsharepath ${prefix}/share/darwinports
132    if ![file isdirectory $portsharepath] {
133        return -code error "Data files directory '$portsharepath' must exist"
134    }
135   
136    if ![info exists libpath] {
137        set libpath "${prefix}/share/darwinports/Tcl"
138    }
139
140    if [file isdirectory $libpath] {
141        lappend auto_path $libpath
142        set darwinports::auto_path $auto_path
143    } else {
144        return -code error "Library directory '$libpath' must exist"
145    }
146}
147
148proc darwinports::worker_init {workername portpath options variations} {
149    global darwinports::portinterp_options auto_path
150
151    # Create package require abstraction procedure
152    $workername eval "proc PortSystem \{version\} \{ \n\
153                        package require port \$version \}"
154
155    foreach proc {dportexec dportopen dportclose dportsearch} {
156        $workername alias $proc $proc
157    }
158
159    # instantiate the UI functions
160    foreach proc {ui_debug ui_info ui_warn ui_msg ui_error ui_gets ui_yesno ui_confirm ui_display} {
161        $workername alias $proc $proc
162    }
163
164    foreach opt $portinterp_options {
165        if ![info exists $opt] {
166            global darwinports::$opt
167        }
168        if [info exists $opt] {
169            $workername eval set system_options($opt) \"[set $opt]\"
170            $workername eval set $opt \"[set $opt]\"
171        } #"
172    }
173
174    foreach {opt val} $options {
175        $workername eval set user_options($opt) $val
176        $workername eval set $opt $val
177    }
178
179    foreach {var val} $variations {
180        $workername eval set variations($var) $val
181    }
182}
183
184proc darwinports::fetch_port {url} {
185    global darwinports::portdbpath tcl_platform
186    set fetchdir [file join $portdbpath portdirs]
187    set fetchfile [file tail $url]
188    if {[catch {file mkdir $fetchdir} result]} {
189        return -code error $result
190    }
191    if {![file writable $fetchdir]} {
192        return -code error "Port remote fetch failed: You do not have permission to write to $fetchdir"
193    }
194    if {${tcl_platform(os)} == "Darwin"} {
195        if {[catch {exec curl -L -s -S -o [file join $fetchdir $fetchfile] $url} result]} {
196            return -code error "Port remote fetch failed: $result"
197        }
198    } else {
199        if {[catch {exec fetch -q -o [file join $fetchdir $fetchfile] $url} result]} {
200            return -code error "Port remote fetch failed: $result"
201        }
202    }
203    if {[catch {cd $fetchdir} result]} {
204        return -code error $result
205    }
206    if {[catch {exec tar -zxf $fetchfile} result]} {
207        return -code error "Port extract failed: $result"
208    }
209    if {[regexp {(.+).tgz} $fetchfile match portdir] != 1} {
210        return -code error "Can't decipher portdir from $fetchfile"
211    }
212    return [file join $fetchdir $portdir]
213}
214
215proc darwinports::getprotocol {url} {
216    if {[regexp {(?x)([^:]+)://.+} $url match protocol] == 1} {
217        return ${protocol}
218    } else {
219        return -code error "Can't parse url $url"
220    }
221}
222
223proc darwinports::getportdir {url} {
224    if {[regexp {(?x)([^:]+)://(.+)} $url match protocol string] == 1} {
225        switch -regexp -- ${protocol} {
226            {^file$} { return $string}
227            {http|ftp} { return [darwinports::fetch_port $url] }
228            default { return -code error "Unsupported protocol $protocol" }
229        }
230    } else {
231        return -code error "Can't parse url $url"
232    }
233}
234
235# dportopen
236# Opens a DarwinPorts portfile specified by a URL.  The portfile is
237# opened with the given list of options and variations.  The result
238# of this function should be treated as an opaque handle to a
239# DarwinPorts Portfile.
240
241proc dportopen {porturl {options ""} {variations ""}} {
242    global darwinports::portinterp_options darwinports::portdbpath darwinports::portconf darwinports::open_dports auto_path
243
244        # Look for an already-open DPort with the same URL.
245        # XXX: should compare options and variations here too.
246        # if found, return the existing reference and bump the refcount.
247        set dport [dlist_search $darwinports::open_dports porturl $porturl]
248        if {$dport != {}} {
249                set refcnt [ditem_key $dport refcnt]
250                incr refcnt
251                ditem_key $dport refcnt $refcnt
252                return $dport
253        }
254
255        set portdir [darwinports::getportdir $porturl]
256        cd $portdir
257        set portpath [pwd]
258        set workername [interp create]
259
260        set dport [ditem_create]
261        lappend darwinports::open_dports $dport
262        ditem_key $dport porturl $porturl
263        ditem_key $dport portpath $portpath
264        ditem_key $dport workername $workername
265        ditem_key $dport options $options
266        ditem_key $dport variations $variations
267        ditem_key $dport refcnt 1
268
269    darwinports::worker_init $workername $portpath $options $variations
270    if ![file isfile Portfile] {
271        return -code error "Could not find Portfile in $portdir"
272    }
273
274    $workername eval source Portfile
275       
276        ditem_key $dport provides [$workername eval return \$portname]
277
278    return $dport
279}
280
281proc _dporttest {dport} {
282        # Check for the presense of the port in the registry
283        set workername [ditem_key $dport workername]
284        set res [$workername eval registry_exists \${portname} \${portversion}]
285        if {$res != ""} {
286                return 1
287        } else {
288                return 0
289        }
290}
291
292proc _dportexec {target dport} {
293        set workername [ditem_key $dport workername]
294        return [$workername eval eval_targets $target]
295}
296
297# dportexec
298# Execute the specified target of the given dport.
299
300proc dportexec {dport target} {
301    global darwinports::portinterp_options
302
303        set workername [ditem_key $dport workername]
304
305        # XXX: move this into dportopen?
306        if {[$workername eval eval_variants variations $target] != 0} {
307                return 1
308        }
309       
310        # Before we build the port, we must build its dependencies.
311        # XXX: need a more general way of comparing against targets
312        set dlist {}
313        if {$target == "configure" || $target == "build" || $target == "install" ||
314                $target == "package" || $target == "mpkg"} {
315
316                dportdepends $dport 1 1
317               
318                # Select out the dependents along the critical path,
319                # but exclude this dport, we might not be installing it.
320                set dlist [dlist_append_dependents $darwinports::open_dports $dport {}]
321               
322                dlist_delete dlist $dport
323
324                # install them
325                set dlist [dlist_eval $dlist _dporttest [list _dportexec "install"]]
326               
327                if {$dlist != {}} {
328                        ui_error "The following dependencies failed to build:"
329                        foreach ditem $dlist {
330                                ui_error "[ditem_key $ditem provides]" nonl
331                        }
332                        ui_error ""
333                        return 1
334                }
335        }
336       
337        # Build this port with the specified target
338        return [$workername eval eval_targets $target]
339       
340        return 0
341}
342
343proc darwinports::getindex {source} {
344    global darwinports::portdbpath
345    # Special case file:// sources
346    if {[darwinports::getprotocol $source] == "file"} {
347        return [file join [darwinports::getportdir $source] PortIndex]
348    }
349    regsub {://} $source {.} source_dir
350    regsub -all {/} $source_dir {_} source_dir
351    return [file join $portdbpath sources $source_dir PortIndex]
352}
353
354proc dportsync {args} {
355    global darwinports::sources darwinports::portdbpath tcl_platform
356
357    foreach source $sources {
358        # Special case file:// sources
359        if {[darwinports::getprotocol $source] == "file"} {
360            continue
361        }
362        set indexfile [darwinports::getindex $source]
363        if {[catch {file mkdir [file dirname $indexfile]} result]} {
364            return -code error $result
365        }
366        if {![file writable [file dirname $indexfile]]} {
367            return -code error "You do not have permission to write to [file dirname $indexfile]"
368        }
369        if {${tcl_platform(os)} == "Darwin"} {
370            exec curl -L -s -S -o $indexfile $source/PortIndex
371        } else {
372            exec fetch -q -o $indexfile $source/PortIndex
373        }
374    }
375}
376
377proc dportsearch {regexp} {
378    global darwinports::portdbpath darwinports::sources
379    set matches [list]
380
381    foreach source $sources {
382        if {[catch {set fd [open [darwinports::getindex $source] r]} result]} {
383            return -code error "Can't open index file for source $source. Have you synced your source indexes?"
384        }
385        while {[gets $fd line] >= 0} {
386            set name [lindex $line 0]
387            if {[regexp -- $regexp $name] == 1} {
388                gets $fd line
389                array set portinfo $line
390                if [info exists portinfo(portarchive)] {
391                    lappend line porturl ${source}/$portinfo(portarchive)
392                } elseif [info exists portinfo(portdir)] {
393                    lappend line porturl ${source}/$portinfo(portdir)
394                }
395                lappend matches $name
396                lappend matches $line
397                set match 1
398            } else {
399                set len [lindex $line 1]
400                seek $fd $len current
401            }
402        }
403        close $fd
404        if {[info exists match] && $match == 1} {
405            break
406        }
407    }
408    return $matches
409}
410
411proc dportinfo {dport} {
412        set workername [ditem_key $dport workername]
413    return [$workername eval array get PortInfo]
414}
415
416proc dportclose {dport} {
417        global darwinports::open_dports
418        set refcnt [ditem_key $dport refcnt]
419        incr refcnt -1
420        ditem_key $dport refcnt $refcnt
421        if {$refcnt == 0} {
422                dlist_delete darwinports::open_dports $dport
423                set workername [ditem_key $dport workername]
424                interp delete $workername
425        }
426}
427
428##### Private Depspec API #####
429# This API should be considered work in progress and subject to change without notice.
430##### "
431
432# dportdepends returns a list of dports which the given port depends on.
433# - optionally includes the build dependencies in the list.
434# - optionally recurses through the dependencies, looking for dependencies
435#       of dependencies.
436
437proc dportdepends {dport includeBuildDeps recurseDeps} {
438        array set portinfo [dportinfo $dport]
439        set depends {}
440        if {[info exists portinfo(depends_run)]} { eval "lappend depends $portinfo(depends_run)" }
441        if {[info exists portinfo(depends_lib)]} { eval "lappend depends $portinfo(depends_lib)" }
442        if {$includeBuildDeps != "" && [info exists portinfo(depends_build)]} {
443                eval "lappend depends $portinfo(depends_build)"
444        }
445
446        foreach depspec $depends {
447                # grab the portname portion of the depspec
448                set portname [lindex [split $depspec :] 2]
449               
450                # Find the porturl
451                if {[catch {set res [dportsearch "^$portname\$"]} error]} {
452                        ui_puts err "Internal error: port search failed: $error"
453                        return 1
454                }
455                foreach {name array} $res {
456                        array set portinfo $array
457                        if {[info exists portinfo(porturl)]} {
458                                set porturl $portinfo(porturl)
459                                break
460                        }
461                }
462
463                set options [ditem_key $dport options]
464                set variations [ditem_key $dport variations]
465               
466                set subport [dportopen $porturl $options $variations]
467
468                # Append the sub-port's provides to the port's requirements list.
469                ditem_append $dport requires "[ditem_key $subport provides]"
470
471                if {$recurseDeps != ""} {
472                        set res [dportdepends $subport $includeBuildDeps $recurseDeps]
473                        if {$res != 0} {
474                                return $res
475                        }
476                }
477        }
478       
479        return 0
480}
Note: See TracBrowser for help on using the repository browser.