source: trunk/base/src/port1.0/portfetch.tcl @ 1015

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

Remove 'register' proc.
Now targets have a handle to the target object directly. Alleviates need for
unique names, and simplifies pre-${target}/post-${target} implementation.
Will allow for future enhancement to options and variants.

  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 9.1 KB
Line 
1# ex:ts=4
2# portfetch.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#
31
32package provide portfetch 1.0
33package require portutil 1.0
34
35set com.apple.fetch [target_new com.apple.fetch fetch_main]
36${com.apple.fetch} set init fetch_init
37${com.apple.fetch} provides fetch
38${com.apple.fetch} requires main
39${com.apple.fetch} deplist depends_fetch
40
41# define options: distname master_sites
42options master_sites patch_sites extract.sufx distfiles patchfiles use_zip use_bzip2 dist_subdir fetch.type cvs.module cvs.root cvs.password cvs.tag
43# XXX we use the command framework to buy us some useful features,
44# but this is not a user-modifiable command
45commands cvs
46commands fetch
47
48# Defaults
49default extract.sufx .tar.gz
50default fetch.type standard
51default cvs.cmd cvs
52default cvs.password ""
53default cvs.dir {${workpath}}
54default cvs.module {$distname}
55default cvs.tag HEAD
56default cvs.env {CVS_PASSFILE=${workpath}/.cvspass}
57default cvs.pre_args {"-d ${cvs.root}"}
58
59default fetch.cmd curl
60default fetch.dir {${distpath}}
61default fetch.args {"-o ${distfile}"}
62default fetch.post_args {"${site}${distfile}"}
63
64# Set distfiles
65default distfiles {[suffix $distname]}
66
67# Option-executed procedures
68namespace eval options { }
69proc options::use_bzip2 {args} {
70    global use_bzip2 extract.sufx
71    if [tbool use_bzip2] {
72        set extract.sufx .tar.bz2
73    }
74}
75
76proc options::use_zip {args} {
77    global use_zip extract.sufx
78    if [tbool use_zip] {
79        set extract.sufx .zip
80    }
81}
82
83# Name space for internal implementation variables
84# Site lists are stored here
85namespace eval portfetch { }
86
87set UI_PREFIX "---> "
88
89# Given a distname, return a suffix based on the use_zip / use_bzip2 / extract.sufx options
90proc suffix {distname} {
91    global extract.sufx use_bzip2 use_zip fetch.type
92        if {"${fetch.type}" == "cvs"} {
93        return ""
94    }
95    if {[tbool use_bzip2]} {
96        return ${distname}.tar.bz2
97    } elseif {[tbool use_zip]} {
98        return ${distname}.zip
99    } else {
100        return ${distname}${extract.sufx}
101    }
102}
103
104# Given a distribution file name, return the appended tag
105# Example: getdisttag distfile.tar.gz:tag1 returns "tag1"
106proc getdisttag {name} {
107    if {[regexp {.+:([A-Za-z]+)} $name match tag]} {
108        return $tag
109    } else {
110        return ""
111    }
112}
113
114# Given a distribution file name, return the name without an attached tag
115# Example : getdistname distfile.tar.gz:tag1 returns "distfile.tar.gz"
116proc getdistname {name} {
117    regexp {(.+):[A-Za-z_-]+} $name match name
118    return $name
119}
120
121# XXX
122# Helper function for portextract.tcl that strips all tag names from a list
123# Used to clean ${distfiles} for setting the ${extract.only} default
124proc disttagclean {list} {
125    if {"$list" == ""} {
126        return $list
127    }
128    foreach name $list {
129        lappend val [getdistname $name]
130    }
131    return $val
132}
133
134# Checks all files and their tags to assemble url lists for later fetching
135# sites tags create variables in the portfetch:: namespace containing all sites
136# within that tag distfiles are added in $site $distfile format, where $site is
137# the name of a variable in the portfetch:: namespace containing a list of fetch
138# sites
139proc checkfiles {args} {
140    global distdir distfiles patchfiles all_dist_files patch_sites fetch_urls \
141        portpath master_sites
142
143    foreach list {master_sites patch_sites} {
144        upvar #0 $list uplist
145        if ![info exists uplist] {
146            continue
147        }
148        foreach site $uplist {
149            if {[regexp {([a-zA-Z]+://.+/):([a-zA-z]+)} $site match site tag] == 1} {
150                lappend portfetch::$tag $site
151            } else {
152                lappend portfetch::$list $site
153            }
154        }
155    }
156
157    if {[info exists patchfiles]} {
158        foreach file $patchfiles {
159            if {![file exists $portpath/files/$file]} {
160        set distsite [getdisttag $file]
161                set file [getdistname $file]
162                lappend all_dist_files $file
163                if {$distsite != ""} {
164                    lappend fetch_urls $distsite $file
165                } elseif {[info exists patch_sites]} {
166                    lappend fetch_urls patch_sites $file
167                } else {
168                    lappend fetch_urls master_sites $file
169                }
170            }
171        }
172    }
173
174    foreach file $distfiles {
175        if {![file exists $portpath/files/$file]} {
176        set distsite [getdisttag $file]
177                set file [getdistname $file]
178                lappend all_dist_files $file
179                if {$distsite != ""} {
180                        lappend fetch_urls $distsite $file
181                } else {
182                    lappend fetch_urls master_sites $file
183                }
184        }
185    }
186}
187
188# Perform a CVS login and fetch, storing the CVS login
189# information in a custom .cvspass file
190proc cvsfetch {args} {
191    global workpath cvs.password cvs.args cvs.post_args cvs.tag cvs.module cvs.cmd cvs.env
192    cd $workpath
193    set cvs.args login
194    set cvs.cmd "echo ${cvs.password} | /usr/bin/env ${cvs.env} cvs"
195    if {[catch {system "[command cvs] 2>&1"} result]} {
196        ui_error "CVS login failed"
197        return -code error "CVS login failed"
198    }
199    set cvs.args "co -r ${cvs.tag}"
200    set cvs.cmd cvs
201    set cvs.post_args "${cvs.module}"
202    if {[catch {system "[command cvs] 2>&1"} result]} {
203        ui_error "CVS check out failed"
204        return -code error "CVS check out failed"
205    }
206    return 0
207}
208
209# Perform a standard fetch, assembling fetch urls from
210# the listed url varable and associated distfile
211proc fetchfiles {args} {
212    global distpath all_dist_files UI_PREFIX ports_verbose fetch_urls fetch.cmd os.platform fetch.pre_args
213    global distfile site
214
215    # Override curl in the case of FreeBSD
216    if {${os.platform} == "freebsd"} {
217        set fetch.cmd "fetch"
218    }
219    if [tbool ports_verbose] {
220        set fetch.pre_args -v
221    } elseif {${os.platform} == "darwin" } {
222        set fetch.pre_args "-s -S"
223    }
224
225    if {![file isdirectory $distpath]} {
226        if {[catch {file mkdir $distpath} result]} {
227            ui_error "Unable to create distribution files path: $result"
228            return -code error "Unable to create distribution files path: $result"
229        }
230    }
231    if {![file writable $distpath]} {
232        ui_error "$distpath must be writable"
233        return -code error "$distpath must be writable"
234    }
235    foreach {url_var distfile} $fetch_urls {
236        if {![file isfile $distpath/$distfile]} {
237            ui_info "$UI_PREFIX $distfile doesn't seem to exist in $distpath"
238            global portfetch::$url_var
239            if ![info exists $url_var] {
240                ui_error "No defined site for tag: $url_var, using master_sites"
241                set url_var master_sites
242                global portfetch::$url_var
243            }
244            foreach site [set $url_var] {
245                ui_msg "$UI_PREFIX Attempting to fetch $distfile from $site"
246                if ![catch {system "[command fetch]"} result] {
247                    set fetched 1
248                    break
249                } else {
250                    ui_error "fetch failed: $result"
251                    exec rm -f ${distpath}/${distfile}
252                }
253            }
254            if {![info exists fetched]} {
255                return -code error "fetch failed."
256            } else {
257                unset fetched
258            }
259        }
260    }
261    return 0
262}
263
264# Initialize fetch target, calling checkfiles if neccesary
265proc fetch_init {args} {
266    global distfiles distname distpath all_dist_files dist_subdir fetch.type
267
268    if {[info exist distpath] && [info exists dist_subdir]} {
269        set distpath ${distpath}/${dist_subdir}
270    }
271    if {"${fetch.type}" == "standard"} {
272        checkfiles
273    }
274}
275
276# Main fetch routine
277# If all_dist_files is not populated and $fetch.type == standard, then
278# there are no files to download. Otherwise, either do a cvs checkout
279# or call the standard fetchfiles procedure
280proc fetch_main {args} {
281    global distname distpath all_dist_files fetch.type
282
283    # Check for files, download if neccesary
284    if {![info exists all_dist_files] && "${fetch.type}" == "standard"} {
285        return 0
286    }
287    if {"${fetch.type}" == "cvs"} {
288        return [cvsfetch]
289    } else {
290            return [fetchfiles]
291    }
292}
Note: See TracBrowser for help on using the repository browser.