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

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

Added darwinports_dlist package for dependency list evaluation in both the
DarwinPorts API and Port API.

  • Property svn:eol-style set to native
File size: 12.3 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
32
33namespace eval darwinports {
34    namespace export bootstrap_options portinterp_options uniqid 0
35    variable bootstrap_options "portdbpath libpath auto_path sources_conf prefix"
36    variable portinterp_options "portdbpath portpath auto_path prefix portsharepath"
37    variable uniqid 0
38}
39
40# Provided UI instantiations
41# For standard messages, the following priorities are defined
42#     debug, info, msg, warn, error
43# Clients of the library are expected to provide ui_puts with the following prototype:
44#     proc ui_puts {priority string nonl}
45# ui_puts should handle the above defined priorities
46
47proc ui_debug {str {nonl ""}} {
48    ui_puts debug "$str" $nonl
49}
50
51proc ui_info {str {nonl ""}} {
52    ui_puts info "$str" $nonl
53}
54
55proc ui_msg {str {nonl ""}} {
56    ui_puts msg "$str" $nonl
57}
58
59proc ui_error {str {nonl ""}} {
60    ui_puts error "$str" $nonl
61}
62
63proc ui_warn {str {nonl ""}} {
64    ui_puts warn "$str" $nonl
65}
66
67proc dportinit {args} {
68    global auto_path env darwinports::portdbpath darwinports::bootstrap_options darwinports::uniqid darwinports::portinterp_options darwinports::portconf darwinports::sources darwinports::sources_conf darwinports::portsharepath
69
70    if {[llength [array names env HOME]] > 0} {
71        set HOME [lindex [array get env HOME] 1]
72        if [file isfile [file join ${HOME} .portsrc]] {
73            set portconf [file join ${HOME} .portsrc]
74            lappend conf_files ${portconf}
75        }
76    }
77
78    if {![info exists portconf] && [file isfile /etc/ports/ports.conf]} {
79        set portconf /etc/ports/ports.conf
80        lappend conf_files /etc/ports/ports.conf
81    }
82    if [info exists conf_files] {
83        foreach file $conf_files {
84            set fd [open $file r]
85            while {[gets $fd line] >= 0} {
86                foreach option $bootstrap_options {
87                    if {[regexp "^$option\[ \t\]+(\[A-Za-z0-9\./\]+$)" $line match val] == 1} {
88                        set darwinports::$option $val
89                        global darwinports::$option
90                    }
91                }
92            }
93        }
94    }
95
96    if {![info exists sources_conf]} {
97        return -code error "sources_conf must be set in /etc/ports/ports.conf or in your .portsrc"
98    }
99    if {[catch {set fd [open $sources_conf r]} result]} {
100        return -code error "$result"
101    }
102    while {[gets $fd line] >= 0} {
103        if ![regexp {[\ \t]*#.*|^$} $line] {
104            lappend sources $line
105        }
106    }
107    if ![info exists sources] {
108        if [file isdirectory dports] {
109            set sources "file://[pwd]/dports"
110        } else {
111            return -code error "No sources defined in $sources_conf"
112        }
113    }
114
115    if ![info exists portdbpath] {
116        return -code error "portdbpath must be set in /etc/ports/ports.conf or in your ~/.portsrc"
117    }
118    if ![file isdirectory $portdbpath] {
119        if ![file exists $portdbpath] {
120            if {[catch {file mkdir $portdbpath} result]} {
121                return -code error "portdbpath $portdbpath does not exist and could not be created: $result"
122            }
123        }
124    }
125    if ![file isdirectory $portdbpath] {
126        return -code error "$portdbpath is not a directory. Please create the directory $portdbpath and try again"
127    }
128
129    set portsharepath ${prefix}/share/darwinports
130    if ![file isdirectory $portsharepath] {
131        return -code error "Data files directory '$portsharepath' must exist"
132    }
133   
134    if ![info exists libpath] {
135        set libpath "${prefix}/share/darwinports/Tcl"
136    }
137
138    if [file isdirectory $libpath] {
139        lappend auto_path $libpath
140        set darwinports::auto_path $auto_path
141    } else {
142        return -code error "Library directory '$libpath' must exist"
143    }
144}
145
146proc darwinports::worker_init {workername portpath options variations} {
147    global darwinports::uniqid darwinports::portinterp_options auto_path
148
149    # Create package require abstraction procedure
150    $workername eval "proc PortSystem \{version\} \{ \n\
151                        package require port \$version \}"
152
153    foreach proc {dportexec dportopen dportclose dportsearch} {
154        $workername alias $proc $proc
155    }
156
157    # instantiate the UI functions
158    foreach proc {ui_debug ui_info ui_warn ui_msg ui_error ui_gets ui_yesno ui_confirm ui_display} {
159        $workername alias $proc $proc
160    }
161
162    foreach opt $portinterp_options {
163        if ![info exists $opt] {
164            global darwinports::$opt
165        }
166        if [info exists $opt] {
167            $workername eval set system_options($opt) \"[set $opt]\"
168            $workername eval set $opt \"[set $opt]\"
169        }
170    }
171
172    foreach {opt val} $options {
173        $workername eval set user_options($opt) $val
174        $workername eval set $opt $val
175    }
176
177    foreach {var val} $variations {
178        $workername eval set variations($var) $val
179    }
180}
181
182proc darwinports::fetch_port {url} {
183    global darwinports::portdbpath tcl_platform
184    set fetchdir [file join $portdbpath portdirs]
185    set fetchfile [file tail $url]
186    if {[catch {file mkdir $fetchdir} result]} {
187        return -code error $result
188    }
189    if {![file writable $fetchdir]} {
190        return -code error "Port remote fetch failed: You do not have permission to write to $fetchdir"
191    }
192    if {${tcl_platform(os)} == "Darwin"} {
193        if {[catch {exec curl -L -s -S -o [file join $fetchdir $fetchfile] $url} result]} {
194            return -code error "Port remote fetch failed: $result"
195        }
196    } else {
197        if {[catch {exec fetch -q -o [file join $fetchdir $fetchfile] $url} result]} {
198            return -code error "Port remote fetch failed: $result"
199        }
200    }
201    if {[catch {cd $fetchdir} result]} {
202        return -code error $result
203    }
204    if {[catch {exec tar -zxf $fetchfile} result]} {
205        return -code error "Port extract failed: $result"
206    }
207    if {[regexp {(.+).tgz} $fetchfile match portdir] != 1} {
208        return -code error "Can't decipher portdir from $fetchfile"
209    }
210    return [file join $fetchdir $portdir]
211}
212
213proc darwinports::getprotocol {url} {
214    if {[regexp {(?x)([^:]+)://.+} $url match protocol] == 1} {
215        return ${protocol}
216    } else {
217        return -code error "Can't parse url $url"
218    }
219}
220
221proc darwinports::getportdir {url} {
222    if {[regexp {(?x)([^:]+)://(.+)} $url match protocol string] == 1} {
223        switch -regexp -- ${protocol} {
224            {^file$} { return $string}
225            {http|ftp} { return [darwinports::fetch_port $url] }
226            default { return -code error "Unsupported protocol $protocol" }
227        }
228    } else {
229        return -code error "Can't parse url $url"
230    }
231}
232
233proc dportopen {porturl {options ""} {variations ""}} {
234    global darwinports::uniqid darwinports::portinterp_options darwinports::portdbpath darwinports::portconf auto_path
235    set portdir [darwinports::getportdir $porturl]
236    cd $portdir
237    set portpath [pwd]
238    set workername workername[incr uniqid]
239    interp create $workername
240    darwinports::worker_init $workername $portpath $options $variations
241    if ![file isfile Portfile] {
242        return -code error "Could not find Portfile in $portdir"
243    }
244    $workername eval source Portfile
245
246    return $workername
247}
248
249proc dportexec {workername target} {
250    global darwinports::portinterp_options darwinports::uniqid
251
252        if {[$workername eval eval_variants variations $target] != 0} {
253                return 1
254        }
255
256        set name [$workername eval return \$portname]
257        puts "xxx: $name depends: [dportdepends $name 1 1]"
258       
259       
260       
261        return [$workername eval eval_targets $target]
262}
263
264proc darwinports::getindex {source} {
265    global darwinports::portdbpath
266    # Special case file:// sources
267    if {[darwinports::getprotocol $source] == "file"} {
268        return [file join [darwinports::getportdir $source] PortIndex]
269    }
270    regsub {://} $source {.} source_dir
271    regsub -all {/} $source_dir {_} source_dir
272    return [file join $portdbpath sources $source_dir PortIndex]
273}
274
275proc dportsync {args} {
276    global darwinports::sources darwinports::portdbpath tcl_platform
277
278    foreach source $sources {
279        # Special case file:// sources
280        if {[darwinports::getprotocol $source] == "file"} {
281            continue
282        }
283        set indexfile [darwinports::getindex $source]
284        if {[catch {file mkdir [file dirname $indexfile]} result]} {
285            return -code error $result
286        }
287        if {![file writable [file dirname $indexfile]]} {
288            return -code error "You do not have permission to write to [file dirname $indexfile]"
289        }
290        if {${tcl_platform(os)} == "Darwin"} {
291            exec curl -L -s -S -o $indexfile $source/PortIndex
292        } else {
293            exec fetch -q -o $indexfile $source/PortIndex
294        }
295    }
296}
297
298proc dportsearch {regexp} {
299    global darwinports::portdbpath darwinports::sources
300    set matches [list]
301
302    foreach source $sources {
303        if {[catch {set fd [open [darwinports::getindex $source] r]} result]} {
304            return -code error "Can't open index file for source $source. Have you synced your source indexes?"
305        }
306        while {[gets $fd line] >= 0} {
307            set name [lindex $line 0]
308            if {[regexp -- $regexp $name] == 1} {
309                gets $fd line
310                array set portinfo $line
311                if [info exists portinfo(portarchive)] {
312                    lappend line porturl ${source}/$portinfo(portarchive)
313                } elseif [info exists portinfo(portdir)] {
314                    lappend line porturl ${source}/$portinfo(portdir)
315                }
316                lappend matches $name
317                lappend matches $line
318                set match 1
319            } else {
320                set len [lindex $line 1]
321                seek $fd $len current
322            }
323        }
324        close $fd
325        if {[info exists match] && $match == 1} {
326            break
327        }
328    }
329    return $matches
330}
331
332proc dportinfo {workername} {
333    return [$workername eval array get PortInfo]
334}
335
336proc dportclose {workername} {
337    interp delete $workername
338}
339
340##### Private Depspec API #####
341# This API should be considered work in progress and subject to change without notice.
342##### "
343
344# dportdepends returns a list of port names which the given port depends on.
345# xxx: should return the depspec itself once we have better depspec processing.
346# - optionally includes the build dependencies in the list.
347# - optionally recurses through the dependencies, looking for dependencies
348#       of dependencies.
349
350proc dportdepends {portname includeBuildDeps recurseDeps} {
351        set result {}
352
353        if {[catch {set res [dportsearch "^$portname\$"]} error]} {
354                ui_puts err "Internal error: port search failed: $error"
355                return
356        }
357
358        foreach {name array} $res {
359                array set portinfo $array
360                set depends {}
361                if {[info exists portinfo(depends_run)]} { eval "lappend depends $portinfo(depends_run)" }
362                if {[info exists portinfo(depends_lib)]} { eval "lappend depends $portinfo(depends_lib)" }
363                if {$includeBuildDeps != "" && [info exists portinfo(depends_build)]} {
364                        eval "lappend depends $portinfo(depends_build)"
365                }
366                foreach depspec $depends {
367                        # grab the portname portion of the depspec
368                        set dep [lindex [split $depspec :] 2]
369                       
370                        lappend result $dep
371                       
372                        if {$recurseDeps != ""} {
373                                set rdeps [dportdepends $dep $includeBuildDeps $recurseDeps]
374                                if {$rdeps == -1} {
375                                        return -1
376                                } else {
377                                        eval "lappend result $rdeps"
378                                }
379                        }
380                }
381        }
382       
383        return $result
384}
Note: See TracBrowser for help on using the repository browser.