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

Last change on this file since 18325 was 18325, checked in by pguyot (Paul Guyot), 14 years ago

New mirror tag: :mirror. This tag appends the DP sub dir to the URL.
What is left for DP mirrors:

  • parallel execution of actions with selectors
  • a new command that uses the new mirror database to clean up the old files.
  • 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.112 2006/06/10 23:04:29 pguyot 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# XXX
138# Helper function for portextract.tcl that strips all tag names from a list
139# Used to clean ${distfiles} for setting the ${extract.only} default
140proc disttagclean {list} {
141    if {"$list" == ""} {
142        return $list
143    }
144    foreach name $list {
145        lappend val [getdistname $name]
146    }
147    return $val
148}
149
150# For a given mirror site type, e.g. "gnu" or "x11", check to see if there's a
151# pre-registered set of sites, and if so, return them.
152proc mirror_sites {mirrors tag subdir} {
153    global UI_PREFIX portname portresourcepath mirror_sites.listfile mirror_sites.listpath dist_subdir
154    source ${mirror_sites.listpath}${mirror_sites.listfile}
155    if {![info exists portfetch::mirror_sites::sites($mirrors)]} {
156        ui_warn "[format [msgcat::mc "No mirror sites on file for class %s"] $mirrors]"
157        return {}
158    }
159   
160    set ret [list]
161    foreach element $portfetch::mirror_sites::sites($mirrors) {
162       
163        # here we have the chance to take a look at tags, that possibly
164        # have been assigned in mirror_sites.tcl
165        set splitlist [split $element :]
166        if {[llength $splitlist] > 1} {
167            set element "[lindex $splitlist 0]:[lindex $splitlist 1]" 
168            set mirror_tag "[lindex $splitlist 2]"
169        }
170
171        if {$mirror_tag == "mirror"} {
172                set thesubdir ${dist_subdir}
173        } elseif {$subdir == "" && $mirror_tag != "nosubdir"} {
174                set thesubdir ${portname}
175        } else {
176                set thesubdir ${subdir}
177        }
178       
179        if {"$tag" != ""} {
180            eval append element "${thesubdir}:${tag}"
181        } else {
182            eval append element "${thesubdir}"
183        }
184        eval lappend ret $element
185    }
186   
187    return $ret
188}
189
190# Checks all files and their tags to assemble url lists for later fetching
191# sites tags create variables in the portfetch:: namespace containing all sites
192# within that tag distfiles are added in $site $distfile format, where $site is
193# the name of a variable in the portfetch:: namespace containing a list of fetch
194# sites
195proc checkfiles {args} {
196    global distfiles patchfiles all_dist_files patch_sites fetch_urls \
197        master_sites filespath master_sites.mirror_subdir \
198        patch_sites.mirror_subdir fallback_mirror_site env
199   
200    append master_sites " ${fallback_mirror_site}"
201    if {[info exists env(MASTER_SITE_LOCAL)]} {
202        set master_sites [concat $env(MASTER_SITE_LOCAL) $master_sites]
203    }
204   
205    append patch_sites " ${fallback_mirror_site}"
206    if {[info exists env(PATCH_SITE_LOCAL)]} {
207        set patch_sites [concat $env(PATCH_SITE_LOCAL) $patch_sites]
208    }
209
210    foreach list {master_sites patch_sites} {
211        upvar #0 $list uplist
212        if {![info exists uplist]} {
213            continue
214        }
215       
216        set site_list [list]
217        foreach site $uplist {
218            if {[regexp {([a-zA-Z]+://.+)} $site match site]} {
219                set site_list [concat $site_list $site]
220            } else {
221                set splitlist [split $site :]
222                if {[llength $splitlist] > 3 || [llength $splitlist] <1} {
223                    ui_error [format [msgcat::mc "Unable to process mirror sites for: %s, ignoring."] $site]
224                }
225                set mirrors "[lindex $splitlist 0]"
226                set subdir "[lindex $splitlist 1]"
227                set tag "[lindex $splitlist 2]"
228                if {[info exists $list.mirror_subdir]} {
229                    append subdir "[set ${list}.mirror_subdir]"
230                }
231                set site_list [concat $site_list [mirror_sites $mirrors $tag $subdir]]
232            }
233        }
234       
235        foreach site $site_list {
236            if {[regexp {([a-zA-Z]+://.+/?):([0-9A-Za-z_-]+)$} $site match site tag]} {
237                lappend portfetch::$tag $site
238            } else {
239                lappend portfetch::$list $site
240            }
241        }
242    }
243   
244    if {[info exists patchfiles]} {
245        foreach file $patchfiles {
246            if {![file exists $filespath/$file]} {
247                set distsite [getdisttag $file]
248                set file [getdistname $file]
249                lappend all_dist_files $file
250                if {$distsite != ""} {
251                    lappend fetch_urls $distsite $file
252                } elseif {[info exists patch_sites]} {
253                    lappend fetch_urls patch_sites $file
254                } else {
255                    lappend fetch_urls master_sites $file
256                }
257            }
258        }
259    }
260   
261    foreach file $distfiles {
262        if {![file exists $filespath/$file]} {
263            set distsite [getdisttag $file]
264            set file [getdistname $file]
265            lappend all_dist_files $file
266            if {$distsite != ""} {
267                lappend fetch_urls $distsite $file
268            } else {
269                lappend fetch_urls master_sites $file
270            }
271        }
272    }
273}
274
275# Perform a CVS login and fetch, storing the CVS login
276# information in a custom .cvspass file
277proc cvsfetch {args} {
278    global workpath cvs.env cvs.cmd cvs.args cvs.post_args
279    global cvs.root cvs.date cvs.tag cvs.password
280
281    set cvs.args "co ${cvs.args}"
282    if {[string length ${cvs.tag}]} {
283        set cvs.args "${cvs.args} -r ${cvs.tag}"
284    }
285
286    if {[string length ${cvs.date}]} {
287        set cvs.args "${cvs.args} -D ${cvs.date}"
288    }
289
290    if {[regexp ^:pserver: ${cvs.root}]} {
291        set savecmd ${cvs.cmd}
292        set saveenv ${cvs.env}
293        set saveargs ${cvs.args}
294        set savepost_args ${cvs.post_args}
295        set cvs.cmd "echo ${cvs.password} | /usr/bin/env ${cvs.env} $portutil::autoconf::cvs_path"
296        set cvs.env ""
297        set cvs.args login
298        set cvs.post_args ""
299        if {[catch {system -notty "[command cvs] 2>&1"} result]} {
300            return -code error [msgcat::mc "CVS login failed"]
301        }
302        set cvs.cmd ${savecmd}
303        set cvs.env ${saveenv}
304        set cvs.args ${saveargs}
305        set cvs.post_args ${savepost_args}
306    } else {
307        set env(CVS_RSH) ssh
308    }
309
310    if {[catch {system "[command cvs] 2>&1"} result]} {
311        return -code error [msgcat::mc "CVS check out failed"]
312    }
313
314    return 0
315}
316
317# Perform an svn fetch
318proc svnfetch {args} {
319    global workpath prefix
320    global svn.env svn.cmd svn.args svn.post_args svn.tag svn.url
321   
322    # Look for the svn command, either in the path or in the prefix
323    set goodcmd 0
324    foreach svncmd "${svn.cmd} ${prefix}/bin/svn svn" {
325        if { [file executable ${svncmd}] } {
326                  set svn.cmd $svncmd
327                  set goodcmd 1
328              break;
329           }
330    }
331    if { !$goodcmd } {
332        ui_error "The subversion tool (svn) is required to fetch ${svn.url}."
333        ui_error "Please install the subversion port before proceeding."
334                return -code error [msgcat::mc "Subversion check out failed"]
335    }
336   
337    set svn.args "checkout ${svn.args}"
338    if {[string length ${svn.tag}]} {
339                set svn.args "${svn.args} -r ${svn.tag}"
340    }
341
342    if {[catch {system "[command svn] 2>&1"} result]} {
343                return -code error [msgcat::mc "Subversion check out failed"]
344    }
345
346    return 0
347}
348
349# Perform a standard fetch, assembling fetch urls from
350# the listed url varable and associated distfile
351proc fetchfiles {args} {
352        global distpath all_dist_files UI_PREFIX fetch_urls
353        global fetch.user fetch.password fetch.use_epsv
354        global distfile site
355        global portverbose
356
357        if {![file isdirectory $distpath]} {
358                if {[catch {file mkdir $distpath} result]} {
359                        return -code error [format [msgcat::mc "Unable to create distribution files path: %s"] $result]
360                }
361        }
362       
363        set fetch_options {}
364        if {[string length ${fetch.user}] || [string length ${fetch.password}]} {
365                lappend fetch_options -u
366                lappend fetch_options "${fetch.user}:${fetch.password}"
367        }
368        if {${fetch.use_epsv} != "yes"} {
369                lappend fetch_options "--disable-epsv"
370        }
371        if {$portverbose == "yes"} {
372                lappend fetch_options "-v"
373        }
374       
375        foreach {url_var distfile} $fetch_urls {
376                if {![file isfile $distpath/$distfile]} {
377                        ui_info "$UI_PREFIX [format [msgcat::mc "%s doesn't seem to exist in %s"] $distfile $distpath]"
378                        if {![file writable $distpath]} {
379                                return -code error [format [msgcat::mc "%s must be writable"] $distpath]
380                        }
381                        global portfetch::$url_var
382                        if {![info exists $url_var]} {
383                                ui_error [format [msgcat::mc "No defined site for tag: %s, using master_sites"] $url_var]
384                                set url_var master_sites
385                                global portfetch::$url_var
386                        }
387                        unset -nocomplain fetched
388                        foreach site [set $url_var] {
389                                ui_msg "$UI_PREFIX [format [msgcat::mc "Attempting to fetch %s from %s"] $distfile $site]"
390                                set file_url [portfetch::assemble_url $site $distfile]
391                                set effectiveURL ""
392                                if {![catch {eval curl fetch --effective-url effectiveURL $fetch_options {$file_url} ${distpath}/${distfile}.TMP} result] &&
393                                        ![catch {system "mv ${distpath}/${distfile}.TMP ${distpath}/${distfile}"}]} {
394
395                                        # Special hack to check for sourceforge mirrors, which don't return a proper error code on failure
396                                        if {![string equal $effectiveURL $file_url] &&
397                                                [string match "*sourceforge*" $file_url] &&
398                                                [string match "*failedmirror*" $effectiveURL]} {
399                                               
400                                                # *SourceForge hackage in effect*
401                                                # The url seen by curl seems to have been a redirect to the sourceforge mirror page
402                                                ui_debug "[msgcat::mc "Fetching from sourceforge mirror failed"]"
403                                                exec rm -f ${distpath}/${distfile}.TMP
404                                               
405                                                # Continue on to try the next mirror, if any
406                                        } else {
407                                       
408                                                # Successful fetch
409                                                set fetched 1
410                                                break
411                                       
412                                        }
413
414                                } else {
415                                        ui_debug "[msgcat::mc "Fetching failed:"]: $result"
416                                        exec rm -f ${distpath}/${distfile}.TMP
417                                }
418                        }
419                        if {![info exists fetched]} {
420                                return -code error [msgcat::mc "fetch failed"]
421                        }
422                }
423        }
424    return 0
425}
426
427# Utility function to delete fetched files.
428proc fetch_deletefiles {args} {
429        global distpath fetch_urls
430        foreach {url_var distfile} $fetch_urls {
431                if {[file isfile $distpath/$distfile]} {
432                        exec rm -f ${distpath}/${distfile}
433                }
434        }
435}
436
437# Utility function to add files to a list of fetched files.
438proc fetch_addfilestomap {filemapname} {
439        global distpath fetch_urls $filemapname
440        foreach {url_var distfile} $fetch_urls {
441                if {[file isfile $distpath/$distfile]} {
442                        filemap set $filemapname $distpath/$distfile 1
443                }
444        }
445}
446
447# Initialize fetch target, calling checkfiles if neccesary
448proc fetch_init {args} {
449    global distfiles distname distpath all_dist_files dist_subdir fetch.type
450   
451    if {[info exist distpath] && [info exists dist_subdir]} {
452        set distpath ${distpath}/${dist_subdir}
453    }
454    if {"${fetch.type}" == "standard"} {
455        checkfiles
456    }
457}
458
459proc fetch_start {args} {
460    global UI_PREFIX portname
461   
462    ui_msg "$UI_PREFIX [format [msgcat::mc "Fetching %s"] $portname]"
463}
464
465# Main fetch routine
466# If all_dist_files is not populated and $fetch.type == standard, then
467# there are no files to download. Otherwise, either do a cvs checkout
468# or call the standard fetchfiles procedure
469proc fetch_main {args} {
470    global distname distpath all_dist_files fetch.type
471
472    # Check for files, download if neccesary
473    if {![info exists all_dist_files] && "${fetch.type}" == "standard"} {
474        return 0
475    }
476   
477    # Fetch the files
478    switch -- "${fetch.type}" {
479        cvs             { return [cvsfetch] }
480        svn             { return [svnfetch] }
481        standard -
482        default { return [fetchfiles] }
483    }
484}
Note: See TracBrowser for help on using the repository browser.