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

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

Suffixes are supported in patchfiles specifications, but the patch command
actually didn't parse the filename and didn't even warn when the patch is not
applied because it cannot be found.

This change fixes that by:

  • moving the distname and disttag-related functions to portutil.tcl
  • fixing portfetch.tcl to actually end up with an error if a patch file cannot

be found (instead of silently ignoring it)

  • fixing portfetch.tcl to actually consider the distname part of the patch files

instead of the whole entry with the optional tag.

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