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

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

Deprecate dportmatch in favor of dportsearch.

  • Property svn:eol-style set to native
File size: 11.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 darwinportsui 1.0 
33
34namespace eval darwinports {
35    namespace export bootstrap_options portinterp_options uniqid 0
36    variable bootstrap_options "portdbpath libpath auto_path sources_conf prefix"
37    variable portinterp_options "portdbpath portpath auto_path portconf portdefaultconf"
38    variable uniqid 0
39}
40
41proc dportinit {args} {
42    global auto_path env darwinports::portdbpath darwinports::bootstrap_options darwinports::uniqid darwinports::portinterp_options darwinports::portconf darwinports::portdefaultconf darwinports::sources darwinports::sources_conf
43
44    if [file isfile /etc/defaults/ports.conf] {
45        set portdefaultconf /etc/defaults/ports.conf
46        lappend conf_files /etc/defaults/ports.conf
47    }
48
49    if {[llength [array names env HOME]] > 0} {
50        set HOME [lindex [array get env HOME] 1]
51        if [file isfile [file join ${HOME} .portsrc]] {
52            set portconf [file join ${HOME} .portsrc]
53            lappend conf_files ${portconf}
54        }
55    }
56
57    if {![info exists portconf] && [file isfile /etc/ports/ports.conf]} {
58        set portconf /etc/ports/ports.conf
59        lappend conf_files /etc/ports/ports.conf
60    }
61    if [info exists conf_files] {
62        foreach file $conf_files {
63            set fd [open $file r]
64            while {[gets $fd line] >= 0} {
65                foreach option $bootstrap_options {
66                    if {[regexp "^$option\[ \t\]+(\[A-Za-z0-9\./\]+$)" $line match val] == 1} {
67                        set $option $val
68                    }
69                }
70            }
71        }
72    }
73
74    if {![info exists sources_conf]} {
75        return -code error "sources_conf must be set in /etc/ports/ports.conf or in your .portsrc"
76    }
77    if {[catch {set fd [open $sources_conf r]} result]} {
78        return -code error "$result"
79    }
80    while {[gets $fd line] >= 0} {
81        if ![regexp {[\ \t]*#.+} $line] {
82            lappend sources $line
83        }
84    }
85    if ![info exists sources] {
86        if [file isdirectory dports] {
87            set sources "file://[pwd]/dports"
88        } else {
89            return -code error "No sources defined in $sources_conf"
90        }
91    }
92
93    if ![info exists portdbpath] {
94        return -code error "portdbpath must be set in /etc/ports/ports.conf or in your ~/.portsrc"
95    }
96    if ![file isdirectory $portdbpath] {
97        if ![file exists $portdbpath] {
98            if {[catch {file mkdir $portdbpath} result]} {
99                return -code error "portdbpath $portdbpath does not exist and could not be created: $result"
100            }
101        }
102    }
103    if ![file isdirectory $portdbpath] {
104        return -code error "$portdbpath is not a directory. Please create the directory $portdbpath and try again"
105    }
106   
107    if ![info exists libpath] {
108        set libpath "${prefix}/share/darwinports/Tcl"
109    }
110
111    if [file isdirectory $libpath] {
112        lappend auto_path $libpath
113    } else {
114        return -code error "Library directory '$libpath' must exist"
115    }
116}
117
118proc darwinports::worker_init {workername portpath options variations} {
119    global darwinports::uniqid darwinports::portinterp_options darwinports::portdbpath darwinports::portconf darwinports::portdefaultconf auto_path
120    if {$options == ""} {
121        set upoptions ""
122    } else {
123        upvar $options upoptions
124    }
125
126    if {$variations == ""} {
127        set upvariations ""
128    } else {
129        upvar $variations upvariations
130    }
131
132    # Create package require abstraction procedure
133    $workername eval "proc PortSystem \{version\} \{ \n\
134                        package require port \$version \}"
135
136    foreach proc {dportexec dportopen dportclose dportsearch dportmatch} {
137                                                                          $workername alias $proc $proc
138                                                                      }
139
140    # instantiate the UI functions
141    foreach proc {ui_init ui_enable ui_disable ui_enabled ui_puts ui_debug ui_info ui_msg ui_error ui_gets ui_yesno ui_confirm ui_display} {
142                                                                                                                                            $workername alias $proc $proc
143                                                                                                                                        }
144
145    foreach proc {ports_verbose ports_quiet ports_debug ports_force} {
146                                                          $workername alias $proc $proc
147                                                      }
148
149    foreach opt $portinterp_options {
150        if [info exists $opt] {
151            $workername eval set system_options($opt) \"[set $opt]\"
152            $workername eval set $opt \"[set $opt]\"
153        }
154    }
155
156    foreach opt [array names upoptions] {
157        $workername eval set user_options($opt) $upoptions($opt)
158        $workername eval set $opt $upoptions($opt)
159    }
160
161    foreach var [array names upvariations] {
162        $workername eval set variations($var) $upvariations($var)
163    }
164}
165
166proc darwinports::fetch_port {url} {
167    global darwinports::portdbpath tcl_platform
168    set fetchdir [file join $portdbpath portdirs]
169    set fetchfile [file tail $url]
170    if {[catch {file mkdir $fetchdir} result]} {
171        return -code error $result
172    }
173    if {![file writable $fetchdir]} {
174        return -code error "Port remote fetch failed: You do not have permission to write to $fetchdir"
175    }
176    if {${tcl_platform(os)} == "Darwin"} {
177        if {[catch {exec curl -s -S -o [file join $fetchdir $fetchfile] $url} result]} {
178            return -code error "Port remote fetch failed: $result"
179        }
180    } else {
181        if {[catch {exec fetch -q -o [file join $fetchdir $fetchfile] $url} result]} {
182            return -code error "Port remote fetch failed: $result"
183        }
184    }
185    if {[catch {cd $fetchdir} result]} {
186        return -code error $result
187    }
188    if {[catch {exec tar -zxf $fetchfile} result]} {
189        return -code error "Port extract failed: $result"
190    }
191    if {[regexp {(.+).tgz} $fetchfile match portdir] != 1} {
192        return -code error "Can't decipher portdir from $fetchfile"
193    }
194    return [file join $fetchdir $portdir]
195}
196
197proc darwinports::getprotocol {url} {
198    if {[regexp {(?x)([^:]+)://.+} $url match protocol] == 1} {
199        return ${protocol}
200    } else {
201        return -code error "Can't parse url $url"
202    }
203}
204
205proc darwinports::getportdir {url} {
206    if {[regexp {(?x)([^:]+)://(.+)} $url match protocol string] == 1} {
207        switch -regexp -- ${protocol} {
208            {^file$} { return $string}
209            {http|ftp} { return [darwinports::fetch_port $url] }
210            default { return -code error "Unsupported protocol $protocol" }
211        }
212    } else {
213        return -code error "Can't parse url $url"
214    }
215}
216
217proc dportopen {porturl {options ""} {variations ""}} {
218    global darwinports::uniqid darwinports::portinterp_options darwinports::portdbpath darwinports::portconf darwinports::portdefaultconf auto_path
219
220    if {$options == ""} {
221        set upoptions ""
222    } else {
223        upvar $options upoptions
224    }
225
226    if {$variations == ""} {
227        set upvariations ""
228    } else {
229        upvar $variations upvariations
230    }
231    set portdir [darwinports::getportdir $porturl]
232    cd $portdir
233    set portpath [pwd]
234    set workername workername[incr uniqid]
235    interp create $workername
236    darwinports::worker_init $workername $portpath upoptions upvariations
237    if ![file isfile Portfile] {
238        return -code error "Could not find Portfile in $portdir"
239    }
240    $workername eval source Portfile
241
242    # initialize the UI for the new port
243    $workername eval ui_init
244
245    return $workername
246}
247
248proc dportexec {workername target} {
249    global darwinports::portinterp_options darwinports::uniqid
250
251        if {[$workername eval eval_variants variations $target] != 0} {
252                return 1
253        }
254       
255        return [$workername eval eval_targets $target]
256}
257
258proc darwinports::getindex {source} {
259    global darwinports::portdbpath
260    # Special case file:// sources
261    if {[darwinports::getprotocol $source] == "file"} {
262        return [file join [darwinports::getportdir $source] PortIndex]
263    }
264    regsub {://} $source {.} source_dir
265    regsub -all {/} $source_dir {_} source_dir
266    return [file join $portdbpath sources $source_dir PortIndex]
267}
268
269# Provide the notion of "forcing" an action.
270proc ports_force {val} {
271    global system_options
272
273    set system_options(ports_force) $val
274}
275
276proc dportsync {args} {
277    global darwinports::sources darwinports::portdbpath tcl_platform
278
279    foreach source $sources {
280        # Special case file:// sources
281        if {[darwinports::getprotocol $source] == "file"} {
282            continue
283        }
284        set indexfile [darwinports::getindex $source]
285        if {[catch {file mkdir [file dirname $indexfile]} result]} {
286            return -code error $result
287        }
288        if {![file writable [file dirname $indexfile]]} {
289            return -code error "You do not have permission to write to [file dirname $indexfile]"
290        }
291        if {${tcl_platform(os)} == "Darwin"} {
292            exec curl -s -S -o $indexfile $source/PortIndex
293        } else {
294            exec fetch -q -o $indexfile $source/PortIndex
295        }
296    }
297}
298
299proc dportsearch {regexp} {
300    global darwinports::portdbpath darwinports::sources
301    set matches [list]
302
303    foreach source $sources {
304        if {[catch {set fd [open [darwinports::getindex $source] r]} result]} {
305            return -code error "Can't open index file for source $source. Have you synced your source indexes?"
306        }
307        while {[gets $fd line] >= 0} {
308            set name [lindex $line 0]
309            if {[regexp -- $regexp $name] == 1} {
310                gets $fd line
311                array set portinfo $line
312                if [info exists portinfo(portarchive)] {
313                    lappend line porturl ${source}/$portinfo(portarchive)
314                } elseif [info exists portinfo(portdir)] {
315                    lappend line porturl ${source}/$portinfo(portdir)
316                }
317                lappend matches $name
318                lappend matches $line
319                set match 1
320            } else {
321                set len [lindex $line 1]
322                seek $fd $len current
323            }
324        }
325        close $fd
326        if {[info exists match] && $match == 1} {
327            break
328        }
329    }
330    return $matches
331}
332
333proc dportmatch {regexp} {
334        return -code error "dportmatch has been deprecated, use dportsearch instead."
335}
336
337proc dportinfo {workername} {
338    return [$workername eval array get PortInfo]
339}
340
341proc dportclose {workername} {
342    interp delete $workername
343}
Note: See TracBrowser for help on using the repository browser.