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

Last change on this file since 2089 was 2089, checked in by kevin, 17 years ago

Propogate build failures back to the dependency evaluator.

  • Property svn:eol-style set to native
File size: 15.2 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                ui_debug "Found Dependency: receipt: $res"
287                return 1
288        } else {
289                return 0
290        }
291}
292
293proc _dportexec {target dport} {
294        # xxx: set the work path?
295        set workername [ditem_key $dport workername]
296        if {![catch {$workername eval eval_targets $target} result] && $result == 0} {
297                # xxx: clean after installing?
298                #$workername eval eval_targets clean
299                return 0
300        } else {
301                # An error occurred.
302                return 1
303        }
304}
305
306# dportexec
307# Execute the specified target of the given dport.
308
309proc dportexec {dport target} {
310    global darwinports::portinterp_options
311
312        set workername [ditem_key $dport workername]
313
314        # XXX: move this into dportopen?
315        if {[$workername eval eval_variants variations $target] != 0} {
316                return 1
317        }
318       
319        # Before we build the port, we must build its dependencies.
320        # XXX: need a more general way of comparing against targets
321        set dlist {}
322        if {$target == "configure" || $target == "build" || $target == "install" ||
323                $target == "package" || $target == "mpkg"} {
324
325                dportdepends $dport 1 1
326               
327                # Select out the dependents along the critical path,
328                # but exclude this dport, we might not be installing it.
329                set dlist [dlist_append_dependents $darwinports::open_dports $dport {}]
330               
331                dlist_delete dlist $dport
332
333                # install them
334                set dlist [dlist_eval $dlist _dporttest [list _dportexec "install"]]
335               
336                if {$dlist != {}} {
337                        ui_error "The following dependencies failed to build:"
338                        foreach ditem $dlist {
339                                ui_error "[ditem_key $ditem provides]" nonl
340                        }
341                        ui_error ""
342                        return 1
343                }
344        }
345       
346        # Build this port with the specified target
347        return [$workername eval eval_targets $target]
348       
349        return 0
350}
351
352proc darwinports::getindex {source} {
353    global darwinports::portdbpath
354    # Special case file:// sources
355    if {[darwinports::getprotocol $source] == "file"} {
356        return [file join [darwinports::getportdir $source] PortIndex]
357    }
358    regsub {://} $source {.} source_dir
359    regsub -all {/} $source_dir {_} source_dir
360    return [file join $portdbpath sources $source_dir PortIndex]
361}
362
363proc dportsync {args} {
364    global darwinports::sources darwinports::portdbpath tcl_platform
365
366    foreach source $sources {
367        # Special case file:// sources
368        if {[darwinports::getprotocol $source] == "file"} {
369            continue
370        }
371        set indexfile [darwinports::getindex $source]
372        if {[catch {file mkdir [file dirname $indexfile]} result]} {
373            return -code error $result
374        }
375        if {![file writable [file dirname $indexfile]]} {
376            return -code error "You do not have permission to write to [file dirname $indexfile]"
377        }
378        if {${tcl_platform(os)} == "Darwin"} {
379            exec curl -L -s -S -o $indexfile $source/PortIndex
380        } else {
381            exec fetch -q -o $indexfile $source/PortIndex
382        }
383    }
384}
385
386proc dportsearch {regexp} {
387    global darwinports::portdbpath darwinports::sources
388    set matches [list]
389
390    foreach source $sources {
391        if {[catch {set fd [open [darwinports::getindex $source] r]} result]} {
392            return -code error "Can't open index file for source $source. Have you synced your source indexes?"
393        }
394        while {[gets $fd line] >= 0} {
395            set name [lindex $line 0]
396            if {[regexp -- $regexp $name] == 1} {
397                gets $fd line
398                array set portinfo $line
399                if [info exists portinfo(portarchive)] {
400                    lappend line porturl ${source}/$portinfo(portarchive)
401                } elseif [info exists portinfo(portdir)] {
402                    lappend line porturl ${source}/$portinfo(portdir)
403                }
404                lappend matches $name
405                lappend matches $line
406                set match 1
407            } else {
408                set len [lindex $line 1]
409                seek $fd $len current
410            }
411        }
412        close $fd
413        if {[info exists match] && $match == 1} {
414            break
415        }
416    }
417    return $matches
418}
419
420proc dportinfo {dport} {
421        set workername [ditem_key $dport workername]
422    return [$workername eval array get PortInfo]
423}
424
425proc dportclose {dport} {
426        global darwinports::open_dports
427        set refcnt [ditem_key $dport refcnt]
428        incr refcnt -1
429        ditem_key $dport refcnt $refcnt
430        if {$refcnt == 0} {
431                dlist_delete darwinports::open_dports $dport
432                set workername [ditem_key $dport workername]
433                interp delete $workername
434        }
435}
436
437##### Private Depspec API #####
438# This API should be considered work in progress and subject to change without notice.
439##### "
440
441# dportdepends returns a list of dports which the given port depends on.
442# - optionally includes the build dependencies in the list.
443# - optionally recurses through the dependencies, looking for dependencies
444#       of dependencies.
445
446proc dportdepends {dport includeBuildDeps recurseDeps} {
447        array set portinfo [dportinfo $dport]
448        set depends {}
449        if {[info exists portinfo(depends_run)]} { eval "lappend depends $portinfo(depends_run)" }
450        if {[info exists portinfo(depends_lib)]} { eval "lappend depends $portinfo(depends_lib)" }
451        if {$includeBuildDeps != "" && [info exists portinfo(depends_build)]} {
452                eval "lappend depends $portinfo(depends_build)"
453        }
454
455        foreach depspec $depends {
456                # grab the portname portion of the depspec
457                set portname [lindex [split $depspec :] 2]
458               
459                # Find the porturl
460                if {[catch {set res [dportsearch "^$portname\$"]} error]} {
461                        ui_puts err "Internal error: port search failed: $error"
462                        return 1
463                }
464                foreach {name array} $res {
465                        array set portinfo $array
466                        if {[info exists portinfo(porturl)]} {
467                                set porturl $portinfo(porturl)
468                                break
469                        }
470                }
471
472                set options [ditem_key $dport options]
473                set variations [ditem_key $dport variations]
474               
475                set subport [dportopen $porturl $options $variations]
476
477                # Append the sub-port's provides to the port's requirements list.
478                ditem_append $dport requires "[ditem_key $subport provides]"
479
480                if {$recurseDeps != ""} {
481                        set res [dportdepends $subport $includeBuildDeps $recurseDeps]
482                        if {$res != 0} {
483                                return $res
484                        }
485                }
486        }
487       
488        return 0
489}
Note: See TracBrowser for help on using the repository browser.