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

Last change on this file since 17197 was 17197, checked in by jberry, 15 years ago

Add a hack to help resolve problems in fetching from sourceforge mirrors.

If we receive a redirect during a fetch, and the url has sourceforge in it,
and the url redirected to contains the words "failedmirror" then assume this
was actually a sourceforge mirror failure, and continue to attempt the fetch
at more mirrors.

  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 15.0 KB
Line 
1# et:ts=4
2# portfetch.tcl
3# $Id: portfetch.tcl,v 1.108 2006/03/27 21:32:27 jberry Exp $
4#
5# Copyright (c) 2002 - 2003 Apple Computer, Inc.
6# All rights reserved.
7#
8# Redistribution and use in source and binary forms, with or without
9# modification, are permitted provided that the following conditions
10# are met:
11# 1. Redistributions of source code must retain the above copyright
12#    notice, this list of conditions and the following disclaimer.
13# 2. Redistributions in binary form must reproduce the above copyright
14#    notice, this list of conditions and the following disclaimer in the
15#    documentation and/or other materials provided with the distribution.
16# 3. Neither the name of Apple Computer, Inc. nor the names of its contributors
17#    may be used to endorse or promote products derived from this software
18#    without specific prior written permission.
19#
20# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
21# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
22# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
23# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
24# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
25# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
26# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
27# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
28# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
29# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
30# POSSIBILITY OF SUCH DAMAGE.
31#
32
33package provide portfetch 1.0
34package require portutil 1.0
35package require Pextlib 1.0
36
37set com.apple.fetch [target_new com.apple.fetch fetch_main]
38target_init ${com.apple.fetch} fetch_init
39target_provides ${com.apple.fetch} fetch
40target_requires ${com.apple.fetch} main
41target_prerun ${com.apple.fetch} fetch_start
42
43# define options: distname master_sites
44options master_sites patch_sites extract.suffix distfiles patchfiles use_zip use_bzip2 dist_subdir \
45        fetch.type fetch.user fetch.password fetch.use_epsv \
46        master_sites.mirror_subdir patch_sites.mirror_subdir portname \
47        cvs.module cvs.root cvs.password cvs.date cvs.tag \
48        svn.url svn.tag
49       
50# XXX we use the command framework to buy us some useful features,
51# but this is not a user-modifiable command
52commands cvs
53commands svn
54
55# Defaults
56default extract.suffix .tar.gz
57default fetch.type standard
58
59default cvs.cmd {$portutil::autoconf::cvs_path}
60default cvs.password ""
61default cvs.dir {${workpath}}
62default cvs.module {$distname}
63default cvs.tag ""
64default cvs.date ""
65default cvs.env {CVS_PASSFILE=${workpath}/.cvspass}
66default cvs.pre_args {"-z9 -f -d ${cvs.root}"}
67default cvs.args ""
68default cvs.post_args {"${cvs.module}"}
69
70default svn.cmd {svn}
71default svn.dir {${workpath}}
72default svn.tag ""
73default svn.env {}
74default svn.pre_args {"--non-interactive"}
75default svn.args ""
76default svn.post_args {"${svn.url}"}
77
78# Set distfiles
79default distfiles {[suffix $distname]}
80default dist_subdir {${portname}}
81
82# user name & password
83default fetch.user ""
84default fetch.password ""
85# Use EPSV for FTP transfers
86default fetch.use_epsv "yes"
87
88default fallback_mirror_site "opendarwin"
89default mirror_sites.listfile {"mirror_sites.tcl"}
90default mirror_sites.listpath {"${portresourcepath}/fetch/"}
91
92# Option-executed procedures
93option_proc use_bzip2 fix_extract_suffix
94option_proc use_zip fix_extract_suffix
95
96proc fix_extract_suffix {option action args} {
97    global extract.suffix
98    if {[string equal ${action} "set"] && [tbool args]} {
99        switch $option {
100            use_bzip2 {
101                set extract.suffix .tar.bz2
102            }
103            use_zip {
104                set extract.suffix .zip
105            }
106        }
107    }
108}
109
110# Name space for internal implementation variables
111# Site lists are stored here
112namespace eval portfetch { }
113
114set_ui_prefix
115
116# Given a distname, return a suffix based on the use_zip / use_bzip2 / extract.suffix options
117proc suffix {distname} {
118    global extract.suffix fetch.type
119    switch -- "${fetch.type}" {
120        cvs                     -
121        svn                     { return "" }
122        standard        -
123        default         { return "${distname}${extract.suffix}" }
124    }
125}
126
127# Given a site url and the name of the distfile, assemble url and
128# return it.
129proc portfetch::assemble_url {site distfile} {
130    if {[string index $site end] != "/"} {
131        return "${site}/${distfile}"
132    } else {
133        return "${site}${distfile}"
134    }
135}
136
137# Given a distribution file name, return the appended tag
138# Example: getdisttag distfile.tar.gz:tag1 returns "tag1"
139# / isn't included in the regexp, thus allowing port specification in URLs.
140proc getdisttag {name} {
141    if {[regexp {.+:([0-9A-Za-z_-]+)$} $name match tag]} {
142        return $tag
143    } else {
144        return ""
145    }
146}
147
148# Given a distribution file name, return the name without an attached tag
149# Example : getdistname distfile.tar.gz:tag1 returns "distfile.tar.gz"
150# / isn't included in the regexp, thus allowing port specification in URLs.
151proc getdistname {name} {
152    regexp {(.+):[0-9A-Za-z_-]+$} $name match name
153    return $name
154}
155
156# XXX
157# Helper function for portextract.tcl that strips all tag names from a list
158# Used to clean ${distfiles} for setting the ${extract.only} default
159proc disttagclean {list} {
160    if {"$list" == ""} {
161        return $list
162    }
163    foreach name $list {
164        lappend val [getdistname $name]
165    }
166    return $val
167}
168
169# For a given mirror site type, e.g. "gnu" or "x11", check to see if there's a
170# pre-registered set of sites, and if so, return them.
171proc mirror_sites {mirrors tag subdir} {
172    global UI_PREFIX portname portresourcepath mirror_sites.listfile mirror_sites.listpath
173    source ${mirror_sites.listpath}${mirror_sites.listfile}
174    if {![info exists portfetch::mirror_sites::sites($mirrors)]} {
175        ui_warn "[format [msgcat::mc "No mirror sites on file for class %s"] $mirrors]"
176        return {}
177    }
178   
179    set ret [list]
180    foreach element $portfetch::mirror_sites::sites($mirrors) {
181       
182        # here we have the chance to take a look at tags, that possibly
183        # have been assigned in mirror_sites.tcl
184        set splitlist [split $element :]
185        if {[llength $splitlist] > 1} {
186            set element "[lindex $splitlist 0]:[lindex $splitlist 1]" 
187            set mirror_tag "[lindex $splitlist 2]"
188        }
189       
190        if {$subdir == "" && $mirror_tag != "nosubdir"} {
191            set subdir ${portname}
192        }
193       
194        if {"$tag" != ""} {
195            eval append element "${subdir}:${tag}"
196        } else {
197            eval append element "${subdir}"
198        }
199        eval lappend ret $element
200    }
201   
202    return $ret
203}
204
205# Checks all files and their tags to assemble url lists for later fetching
206# sites tags create variables in the portfetch:: namespace containing all sites
207# within that tag distfiles are added in $site $distfile format, where $site is
208# the name of a variable in the portfetch:: namespace containing a list of fetch
209# sites
210proc checkfiles {args} {
211    global distfiles patchfiles all_dist_files patch_sites fetch_urls \
212        master_sites filespath master_sites.mirror_subdir \
213        patch_sites.mirror_subdir fallback_mirror_site env
214   
215    append master_sites " ${fallback_mirror_site}"
216    if {[info exists env(MASTER_SITE_LOCAL)]} {
217        set master_sites [concat $env(MASTER_SITE_LOCAL) $master_sites]
218    }
219   
220    append patch_sites " ${fallback_mirror_site}"
221    if {[info exists env(PATCH_SITE_LOCAL)]} {
222        set patch_sites [concat $env(PATCH_SITE_LOCAL) $patch_sites]
223    }
224
225    foreach list {master_sites patch_sites} {
226        upvar #0 $list uplist
227        if {![info exists uplist]} {
228            continue
229        }
230       
231        set site_list [list]
232        foreach site $uplist {
233            if {[regexp {([a-zA-Z]+://.+)} $site match site]} {
234                set site_list [concat $site_list $site]
235            } else {
236                set splitlist [split $site :]
237                if {[llength $splitlist] > 3 || [llength $splitlist] <1} {
238                    ui_error [format [msgcat::mc "Unable to process mirror sites for: %s, ignoring."] $site]
239                }
240                set mirrors "[lindex $splitlist 0]"
241                set subdir "[lindex $splitlist 1]"
242                set tag "[lindex $splitlist 2]"
243                if {[info exists $list.mirror_subdir]} {
244                    append subdir "[set ${list}.mirror_subdir]"
245                }
246                set site_list [concat $site_list [mirror_sites $mirrors $tag $subdir]]
247            }
248        }
249       
250        foreach site $site_list {
251            if {[regexp {([a-zA-Z]+://.+/?):([0-9A-Za-z_-]+)$} $site match site tag]} {
252                lappend portfetch::$tag $site
253            } else {
254                lappend portfetch::$list $site
255            }
256        }
257    }
258   
259    if {[info exists patchfiles]} {
260        foreach file $patchfiles {
261            if {![file exists $filespath/$file]} {
262                set distsite [getdisttag $file]
263                set file [getdistname $file]
264                lappend all_dist_files $file
265                if {$distsite != ""} {
266                    lappend fetch_urls $distsite $file
267                } elseif {[info exists patch_sites]} {
268                    lappend fetch_urls patch_sites $file
269                } else {
270                    lappend fetch_urls master_sites $file
271                }
272            }
273        }
274    }
275   
276    foreach file $distfiles {
277        if {![file exists $filespath/$file]} {
278            set distsite [getdisttag $file]
279            set file [getdistname $file]
280            lappend all_dist_files $file
281            if {$distsite != ""} {
282                lappend fetch_urls $distsite $file
283            } else {
284                lappend fetch_urls master_sites $file
285            }
286        }
287    }
288}
289
290# Perform a CVS login and fetch, storing the CVS login
291# information in a custom .cvspass file
292proc cvsfetch {args} {
293    global workpath cvs.env cvs.cmd cvs.args cvs.post_args
294    global cvs.root cvs.date cvs.tag cvs.password
295
296    set cvs.args "co ${cvs.args}"
297    if {[string length ${cvs.tag}]} {
298        set cvs.args "${cvs.args} -r ${cvs.tag}"
299    }
300
301    if {[string length ${cvs.date}]} {
302        set cvs.args "${cvs.args} -D ${cvs.date}"
303    }
304
305    if {[regexp ^:pserver: ${cvs.root}]} {
306        set savecmd ${cvs.cmd}
307        set saveenv ${cvs.env}
308        set saveargs ${cvs.args}
309        set savepost_args ${cvs.post_args}
310        set cvs.cmd "echo ${cvs.password} | /usr/bin/env ${cvs.env} $portutil::autoconf::cvs_path"
311        set cvs.env ""
312        set cvs.args login
313        set cvs.post_args ""
314        if {[catch {system -notty "[command cvs] 2>&1"} result]} {
315            return -code error [msgcat::mc "CVS login failed"]
316        }
317        set cvs.cmd ${savecmd}
318        set cvs.env ${saveenv}
319        set cvs.args ${saveargs}
320        set cvs.post_args ${savepost_args}
321    } else {
322        set env(CVS_RSH) ssh
323    }
324
325    if {[catch {system "[command cvs] 2>&1"} result]} {
326        return -code error [msgcat::mc "CVS check out failed"]
327    }
328
329    return 0
330}
331
332# Perform an svn fetch
333proc svnfetch {args} {
334    global workpath prefix
335    global svn.env svn.cmd svn.args svn.post_args svn.tag svn.url
336   
337    # Look for the svn command, either in the path or in the prefix
338    set goodcmd 0
339    foreach svncmd "${svn.cmd} ${prefix}/bin/svn svn" {
340        if { [file executable ${svncmd}] } {
341                  set svn.cmd $svncmd
342                  set goodcmd 1
343              break;
344           }
345    }
346    if { !$goodcmd } {
347        ui_error "The subversion tool (svn) is required to fetch ${svn.url}."
348        ui_error "Please install the subversion port before proceeding."
349                return -code error [msgcat::mc "Subversion check out failed"]
350    }
351   
352    set svn.args "checkout ${svn.args}"
353    if {[string length ${svn.tag}]} {
354                set svn.args "${svn.args} -r ${svn.tag}"
355    }
356
357    if {[catch {system "[command svn] 2>&1"} result]} {
358                return -code error [msgcat::mc "Subversion check out failed"]
359    }
360
361    return 0
362}
363
364# Perform a standard fetch, assembling fetch urls from
365# the listed url varable and associated distfile
366proc fetchfiles {args} {
367        global distpath all_dist_files UI_PREFIX fetch_urls
368        global fetch.user fetch.password fetch.use_epsv
369        global distfile site
370        global portverbose
371
372        if {![file isdirectory $distpath]} {
373                if {[catch {file mkdir $distpath} result]} {
374                        return -code error [format [msgcat::mc "Unable to create distribution files path: %s"] $result]
375                }
376        }
377       
378        set fetch_options {}
379        if {[string length ${fetch.user}] || [string length ${fetch.password}]} {
380                lappend fetch_options -u
381                lappend fetch_options "${fetch.user}:${fetch.password}"
382        }
383        if {${fetch.use_epsv} != "yes"} {
384                lappend fetch_options "--disable-epsv"
385        }
386        if {$portverbose == "yes"} {
387                lappend fetch_options "-v"
388        }
389       
390        foreach {url_var distfile} $fetch_urls {
391                if {![file isfile $distpath/$distfile]} {
392                        ui_info "$UI_PREFIX [format [msgcat::mc "%s doesn't seem to exist in %s"] $distfile $distpath]"
393                        if {![file writable $distpath]} {
394                                return -code error [format [msgcat::mc "%s must be writable"] $distpath]
395                        }
396                        global portfetch::$url_var
397                        if {![info exists $url_var]} {
398                                ui_error [format [msgcat::mc "No defined site for tag: %s, using master_sites"] $url_var]
399                                set url_var master_sites
400                                global portfetch::$url_var
401                        }
402                        unset -nocomplain fetched
403                        foreach site [set $url_var] {
404                                ui_msg "$UI_PREFIX [format [msgcat::mc "Attempting to fetch %s from %s"] $distfile $site]"
405                                set file_url [portfetch::assemble_url $site $distfile]
406                                set effectiveURL ""
407                                if {![catch {eval curl fetch --effective-url effectiveURL $fetch_options {$file_url} ${distpath}/${distfile}.TMP} result] &&
408                                        ![catch {system "mv ${distpath}/${distfile}.TMP ${distpath}/${distfile}"}]} {
409
410                                        # Special hack to check for sourceforge mirrors, which don't return a proper error code on failure
411                                        if {![string equal $effectiveURL $file_url] &&
412                                                [string match "*sourceforge*" $file_url] &&
413                                                [string match "*failedmirror*" $effectiveURL]} {
414                                               
415                                                # *SourceForge hackage in effect*
416                                                # The url seen by curl seems to have been a redirect to the sourceforge mirror page
417                                                ui_debug "[msgcat::mc "Fetching from sourceforge mirror failed"]"
418                                                exec rm -f ${distpath}/${distfile}.TMP
419                                               
420                                                # Continue on to try the next mirror, if any
421                                        } else {
422                                       
423                                                # Successful fetch
424                                                set fetched 1
425                                                break
426                                       
427                                        }
428
429                                } else {
430                                        ui_debug "[msgcat::mc "Fetching failed:"]: $result"
431                                        exec rm -f ${distpath}/${distfile}.TMP
432                                }
433                        }
434                        if {![info exists fetched]} {
435                                return -code error [msgcat::mc "fetch failed"]
436                        }
437                }
438        }
439    return 0
440}
441
442# Initialize fetch target, calling checkfiles if neccesary
443proc fetch_init {args} {
444    global distfiles distname distpath all_dist_files dist_subdir fetch.type
445   
446    if {[info exist distpath] && [info exists dist_subdir]} {
447        set distpath ${distpath}/${dist_subdir}
448    }
449    if {"${fetch.type}" == "standard"} {
450        checkfiles
451    }
452}
453
454proc fetch_start {args} {
455    global UI_PREFIX portname
456   
457    ui_msg "$UI_PREFIX [format [msgcat::mc "Fetching %s"] $portname]"
458}
459
460# Main fetch routine
461# If all_dist_files is not populated and $fetch.type == standard, then
462# there are no files to download. Otherwise, either do a cvs checkout
463# or call the standard fetchfiles procedure
464proc fetch_main {args} {
465    global distname distpath all_dist_files fetch.type
466   
467    # Check for files, download if neccesary
468    if {![info exists all_dist_files] && "${fetch.type}" == "standard"} {
469        return 0
470    }
471   
472    # Fetch the files
473    switch -- "${fetch.type}" {
474        cvs             { return [cvsfetch] }
475        svn             { return [svnfetch] }
476        standard -
477        default { return [fetchfiles] }
478    }
479}
Note: See TracBrowser for help on using the repository browser.