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

Last change on this file since 1590 was 1590, checked in by landonf (Landon Fuller), 18 years ago

Ensure that the prefix gets to the port API.
This file needs a clean-up ...

  • Property svn:eol-style set to native
File size: 10.8 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        return [$workername eval eval_targets $target]
257}
258
259proc darwinports::getindex {source} {
260    global darwinports::portdbpath
261    # Special case file:// sources
262    if {[darwinports::getprotocol $source] == "file"} {
263        return [file join [darwinports::getportdir $source] PortIndex]
264    }
265    regsub {://} $source {.} source_dir
266    regsub -all {/} $source_dir {_} source_dir
267    return [file join $portdbpath sources $source_dir PortIndex]
268}
269
270proc dportsync {args} {
271    global darwinports::sources darwinports::portdbpath tcl_platform
272
273    foreach source $sources {
274        # Special case file:// sources
275        if {[darwinports::getprotocol $source] == "file"} {
276            continue
277        }
278        set indexfile [darwinports::getindex $source]
279        if {[catch {file mkdir [file dirname $indexfile]} result]} {
280            return -code error $result
281        }
282        if {![file writable [file dirname $indexfile]]} {
283            return -code error "You do not have permission to write to [file dirname $indexfile]"
284        }
285        if {${tcl_platform(os)} == "Darwin"} {
286            exec curl -L -s -S -o $indexfile $source/PortIndex
287        } else {
288            exec fetch -q -o $indexfile $source/PortIndex
289        }
290    }
291}
292
293proc dportsearch {regexp} {
294    global darwinports::portdbpath darwinports::sources
295    set matches [list]
296
297    foreach source $sources {
298        if {[catch {set fd [open [darwinports::getindex $source] r]} result]} {
299            return -code error "Can't open index file for source $source. Have you synced your source indexes?"
300        }
301        while {[gets $fd line] >= 0} {
302            set name [lindex $line 0]
303            if {[regexp -- $regexp $name] == 1} {
304                gets $fd line
305                array set portinfo $line
306                if [info exists portinfo(portarchive)] {
307                    lappend line porturl ${source}/$portinfo(portarchive)
308                } elseif [info exists portinfo(portdir)] {
309                    lappend line porturl ${source}/$portinfo(portdir)
310                }
311                lappend matches $name
312                lappend matches $line
313                set match 1
314            } else {
315                set len [lindex $line 1]
316                seek $fd $len current
317            }
318        }
319        close $fd
320        if {[info exists match] && $match == 1} {
321            break
322        }
323    }
324    return $matches
325}
326
327proc dportinfo {workername} {
328    return [$workername eval array get PortInfo]
329}
330
331proc dportclose {workername} {
332    interp delete $workername
333}
Note: See TracBrowser for help on using the repository browser.