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

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

Store variants in state file. Print error if state exists with different
set of variants.

  • Property svn:eol-style set to native
File size: 12.0 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                    set portinfo(porturl) ${source}/$portinfo(portarchive)
314                } elseif [info exists portinfo(portdir)] {
315                    set portinfo(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    global darwinports::portdbpath darwinports::sources
335    foreach source $sources {
336        if {[catch {set fd [open [darwinports::getindex $source] r]} result]} {
337            return -code error "Can't open index file for source $source. Have you synced your source indexes?"
338        }
339        while {[gets $fd line] >= 0} {
340            set name [lindex $line 0]
341            if {[regexp -- $regexp $name] == 1} {
342                gets $fd line
343                array set portinfo $line
344                if [info exists portinfo(portarchive)] {
345                    set portinfo(porturl) ${source}/$portinfo(portarchive)
346                } elseif [info exists portinfo(portdir)] {
347                    set portinfo(porturl) ${source}/$portinfo(portdir)
348                }
349                close $fd
350                return [array get portinfo]
351            } else {
352                set len [lindex $line 1]
353                seek $fd $len current
354            }
355        }
356        close $fd
357    }
358}
359
360proc dportinfo {workername} {
361    return [$workername eval array get PortInfo]
362}
363
364proc dportclose {workername} {
365    interp delete $workername
366}
Note: See TracBrowser for help on using the repository browser.