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

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

Commit jpm's patch to use curl's support for HTTP redirection

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