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

Last change on this file since 42662 was 42662, checked in by raimue@…, 12 years ago

Merged revisions 34469,34852,34854-34855,34900,36952-36956,37507-37508,37511-37512,41040,41042-41046,41138-41139,41142-41143,41145,41151,41403,41458,41462-41463,42575,42626,42640-42641,42659 via svnmerge from
https://svn.macosforge.org/repository/macports/branches/variant-descs-14482/base

........

r34469 | raimue@… | 2008-02-26 07:08:09 +0100 (Tue, 26 Feb 2008) | 3 lines


port/port.tcl:
Reading from .config/variant_descriptions actually works

........

r34852 | raimue@… | 2008-03-09 02:45:22 +0100 (Sun, 09 Mar 2008) | 4 lines


macports1.0/macports.tcl:
New API: macports::getsourceconfigdir
Returns the path to .config for a porturl.

........

r34854 | raimue@… | 2008-03-09 03:11:27 +0100 (Sun, 09 Mar 2008) | 3 lines


port/port.tcl:
Use new API macports::getsourceconfigdir

........

r34855 | raimue@… | 2008-03-09 03:12:54 +0100 (Sun, 09 Mar 2008) | 3 lines


port/port.tcl:
Treat variant descriptions as strings to avoid problems with braces

........

r34900 | raimue@… | 2008-03-10 16:54:25 +0100 (Mon, 10 Mar 2008) | 3 lines


port/port.tcl:
Rename variable

........

r36952 | raimue@… | 2008-05-21 04:20:27 +0200 (Wed, 21 May 2008) | 3 lines


port/port.tcl:
Remove get_variant_desc, this will now be done in port1.0/portutil.tcl instead

........

r36953 | raimue@… | 2008-05-21 04:22:04 +0200 (Wed, 21 May 2008) | 3 lines


macports1.0/macports.tcl:
Give the worker access to variable porturl and proc getsourceconfigdir

........

r36954 | raimue@… | 2008-05-21 04:23:37 +0200 (Wed, 21 May 2008) | 3 lines


port1.0/tests:
Fix the portutil test after r36953

........

r36955 | raimue@… | 2008-05-21 05:01:11 +0200 (Wed, 21 May 2008) | 3 lines


macports1.0/macports.tcl:
Give worker access to getprotocol and getportdir as they are needed for getsourceconfigdir

........

r36956 | raimue@… | 2008-05-21 05:02:23 +0200 (Wed, 21 May 2008) | 3 lines


port1.0/portutil.tcl:
New proc variant_desc, reads global variant description file

........

r37507 | raimue@… | 2008-06-10 16:04:54 +0200 (Tue, 10 Jun 2008) | 4 lines


port1.0/portutil.tcl:
Don't warn about a missing description if it is set global,
but warn if the variant overrides the global description

........

r37508 | raimue@… | 2008-06-10 16:14:03 +0200 (Tue, 10 Jun 2008) | 3 lines


macports1.0/macports.tcl:
Use .resources instead of .config as it is a bit clearer, see #14553

........

r37511 | raimue@… | 2008-06-10 17:22:12 +0200 (Tue, 10 Jun 2008) | 5 lines


port1.0/portutil.tcl:
Switch back to this format:
name {description}
So this could be easily extended if ever needed.

........

r37512 | raimue@… | 2008-06-10 17:27:48 +0200 (Tue, 10 Jun 2008) | 3 lines


port1.0/portutil.tcl:
Add a warning if global variant description file could not be opened

........

r41040 | raimue@… | 2008-10-21 13:06:39 +0200 (Tue, 21 Oct 2008) | 4 lines


macports/macport.tcl:

  • New flag "default" for sources to indicate fallback for resources (group)
  • Add parameter to getsourceconfigdir to get path for a requested file

........

r41042 | raimue@… | 2008-10-21 13:11:44 +0200 (Tue, 21 Oct 2008) | 3 lines


macports1.0/macports.tcl:
Rename getsourceconfigdir to getportresourcepath

........

r41043 | raimue@… | 2008-10-21 13:15:16 +0200 (Tue, 21 Oct 2008) | 3 lines


port1.0/portutil.tcl:
Use getportresourcepath for the group files

........

r41044 | raimue@… | 2008-10-21 13:19:47 +0200 (Tue, 21 Oct 2008) | 3 lines


port1.0/portlint.tcl:
Use getresourcepath for group files

........

r41045 | raimue@… | 2008-10-21 13:20:36 +0200 (Tue, 21 Oct 2008) | 3 lines


port1.0/portmain.tcl:
Add a note that we should get rid of $portresourcepath in favor of [getportresourcepath]

........

r41046 | raimue@… | 2008-10-21 13:40:29 +0200 (Tue, 21 Oct 2008) | 3 lines


port1.0/portutil.tcl:
Missed one instance of getsourceconfigdir

........

r41138 | raimue@… | 2008-10-25 20:52:50 +0200 (Sat, 25 Oct 2008) | 3 lines


port1.0/portutil.tcl:
Use getportresourcepath for global variant descriptions

........

r41139 | raimue@… | 2008-10-25 21:23:15 +0200 (Sat, 25 Oct 2008) | 3 lines


port1.0/portmain.tcl:
Correct XXX tag

........

r41142 | raimue@… | 2008-10-25 23:11:30 +0200 (Sat, 25 Oct 2008) | 3 lines


port1.0/portfetch.tcl:
Use getportresourcepath

........

r41143 | raimue@… | 2008-10-25 23:12:04 +0200 (Sat, 25 Oct 2008) | 3 lines


port1.0/portdestroot.tcl:
Use getportresourcepath

........

r41145 | raimue@… | 2008-10-26 00:04:15 +0200 (Sun, 26 Oct 2008) | 3 lines


macports1.0/macports.tcl:
Fix a problem with URLs not using the file protocol

........

r41151 | raimue@… | 2008-10-26 03:09:54 +0100 (Sun, 26 Oct 2008) | 3 lines


macports1.0/macports.tcl:
Fix issues introduced in r41145, the file exists check was wrong

........

r41403 | raimue@… | 2008-11-01 22:59:21 +0100 (Sat, 01 Nov 2008) | 3 lines


port1.0/portutil.tcl:
Add a debug output which group files are used

........

r41458 | blb@… | 2008-11-03 22:58:28 +0100 (Mon, 03 Nov 2008) | 2 lines


Add [default] tag and description to sources.conf

........

r41462 | blb@… | 2008-11-04 02:12:28 +0100 (Tue, 04 Nov 2008) | 2 lines


No longer need to install resources with base

........

r41463 | blb@… | 2008-11-04 02:14:49 +0100 (Tue, 04 Nov 2008) | 4 lines


Move the install/ subdir (containing the mtree files) into .../share/macports
from the resources dir (the mtree contains a bit of install-time info, so it
shouldn't be with the resources stuff in the port tree)

........

r42575 | blb@… | 2008-11-25 01:53:05 +0100 (Tue, 25 Nov 2008) | 3 lines


Add script to handle upgrades through configure/make/make install and
the package, so [default] is added as appropriate to sources.conf

........

r42626 | raimue@… | 2008-11-27 02:21:15 +0100 (Thu, 27 Nov 2008) | 3 lines


package1.0/portpkg.tcl, package1.0/portmpkg.tcl:
Remove portresourcepath and use [getportresourcepath] instead

........

r42640 | raimue@… | 2008-11-27 11:49:32 +0100 (Thu, 27 Nov 2008) | 3 lines


package1.0/portrpm.tcl, package1.0/portsrpm.tcl:
Remove reference to portresurcepath which is not used at all

........

r42641 | raimue@… | 2008-11-27 11:52:12 +0100 (Thu, 27 Nov 2008) | 3 lines


port1.0/portmain.tcl:
Remove definition of portresourcepath as it is not used any more

........

r42659 | raimue@… | 2008-11-28 16:44:30 +0100 (Fri, 28 Nov 2008) | 3 lines


macports1.0/macports.tcl:
Rename portresourcepath from .resources to _resources

........

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 22.9 KB
Line 
1# -*- coding: utf-8; mode: tcl; tab-width: 4; indent-tabs-mode: nil; c-basic-offset: 4 -*- vim:fenc=utf-8:ft=tcl:et:sw=4:ts=4:sts=4
2# portfetch.tcl
3# $Id: portfetch.tcl 42662 2008-11-28 23:18:50Z raimue@macports.org $
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 org.macports.fetch [target_new org.macports.fetch fetch_main]
38target_init ${org.macports.fetch} fetch_init
39target_provides ${org.macports.fetch} fetch
40target_requires ${org.macports.fetch} main
41target_prerun ${org.macports.fetch} fetch_start
42
43# define options: distname master_sites
44options master_sites patch_sites extract.suffix distfiles patchfiles use_zip use_bzip2 use_dmg dist_subdir \
45        fetch.type fetch.user fetch.password fetch.use_epsv fetch.ignore_sslcert \
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        git.url git.branch \
50        hg.url hg.tag
51       
52# XXX we use the command framework to buy us some useful features,
53# but this is not a user-modifiable command
54commands cvs
55commands svn
56
57# Defaults
58default extract.suffix .tar.gz
59default fetch.type standard
60
61default cvs.cmd {$portutil::autoconf::cvs_path}
62default cvs.password ""
63default cvs.dir {${workpath}}
64default cvs.module {$distname}
65default cvs.tag ""
66default cvs.date ""
67default cvs.env {CVS_PASSFILE=${workpath}/.cvspass}
68default cvs.pre_args {"-z9 -f -d ${cvs.root}"}
69default cvs.args ""
70default cvs.post_args {"${cvs.module}"}
71
72default svn.cmd {$portutil::autoconf::svn_path}
73default svn.dir {${workpath}}
74default svn.tag ""
75default svn.env {}
76default svn.pre_args {"--non-interactive"}
77default svn.args ""
78default svn.post_args {"${svn.url}"}
79
80default git.dir {${workpath}}
81default git.branch {}
82
83default hg.dir {${workpath}}
84default hg.tag {tip}
85
86# Set distfiles
87default distfiles {[suffix $distname]}
88default dist_subdir {${portname}}
89
90# user name & password
91default fetch.user ""
92default fetch.password ""
93# Use EPSV for FTP transfers
94default fetch.use_epsv "yes"
95# Ignore SSL certificate
96default fetch.ignore_sslcert "no"
97# Use remote timestamps
98default fetch.remote_time "no"
99
100default fallback_mirror_site "macports"
101default global_mirror_site "macports_distfiles"
102default mirror_sites.listfile {"mirror_sites.tcl"}
103default mirror_sites.listpath {"port1.0/fetch"}
104
105# Option-executed procedures
106option_proc use_bzip2 fix_extract_suffix
107option_proc use_lzma fix_extract_suffix
108option_proc use_zip fix_extract_suffix
109option_proc use_dmg fix_extract_suffix
110
111proc fix_extract_suffix {option action args} {
112    global extract.suffix
113    if {[string equal ${action} "set"] && [tbool args]} {
114        switch $option {
115            use_bzip2 {
116                set extract.suffix .tar.bz2
117            }
118            use_lzma {
119                set extract.suffix .tar.lzma
120            }
121            use_zip {
122                set extract.suffix .zip
123            }
124            use_dmg {
125                set extract.suffix .dmg
126            }
127        }
128    }
129}
130
131# Name space for internal implementation variables
132# Site lists are stored here
133namespace eval portfetch { }
134
135set_ui_prefix
136
137# Given a distname, return a suffix based on the use_zip / use_bzip2 / use_dmg / extract.suffix options
138proc suffix {distname} {
139    global extract.suffix fetch.type
140    switch -- "${fetch.type}" {
141        cvs                     -
142        svn                     -
143        git                     -
144        hg                      { return "" }
145        standard        -
146        default         { return "${distname}${extract.suffix}" }
147    }
148}
149
150# Given a site url and the name of the distfile, assemble url and
151# return it.
152proc portfetch::assemble_url {site distfile} {
153    if {[string index $site end] != "/"} {
154        return "${site}/${distfile}"
155    } else {
156        return "${site}${distfile}"
157    }
158}
159
160# XXX
161# Helper function for portextract.tcl that strips all tag names from a list
162# Used to clean ${distfiles} for setting the ${extract.only} default
163proc disttagclean {list} {
164    if {"$list" == ""} {
165        return $list
166    }
167    foreach name $list {
168        lappend val [getdistname $name]
169    }
170    return $val
171}
172
173# For a given mirror site type, e.g. "gnu" or "x11", check to see if there's a
174# pre-registered set of sites, and if so, return them.
175proc mirror_sites {mirrors tag subdir} {
176    global UI_PREFIX portname porturl mirror_sites.listfile mirror_sites.listpath dist_subdir
177
178    source [getportresourcepath $porturl [file join ${mirror_sites.listpath} ${mirror_sites.listfile}]]
179
180    if {![info exists portfetch::mirror_sites::sites($mirrors)]} {
181        ui_warn "[format [msgcat::mc "No mirror sites on file for class %s"] $mirrors]"
182        return {}
183    }
184   
185    set ret [list]
186    foreach element $portfetch::mirror_sites::sites($mirrors) {
187       
188        # here we have the chance to take a look at tags, that possibly
189        # have been assigned in mirror_sites.tcl
190        set splitlist [split $element :]
191        # every element is a URL, so we'll always have multiple elements. no need to check
192    set element "[lindex $splitlist 0]:[lindex $splitlist 1]" 
193    set mirror_tag "[lindex $splitlist 2]"
194
195    set name_re {\$(?:name\y|\{name\})}
196    # if the URL has $name embedded, kill any mirror_tag that may have been added
197    # since a mirror_tag and $name are incompatible
198    if {[regexp $name_re $element]} {
199        set mirror_tag ""
200    }
201   
202        if {$mirror_tag == "mirror"} {
203                set thesubdir ${dist_subdir}
204        } elseif {$subdir == "" && $mirror_tag != "nosubdir"} {
205                set thesubdir ${portname}
206        } else {
207                set thesubdir ${subdir}
208        }
209       
210        # parse an embedded $name. if present, remove the subdir
211        if {[regsub $name_re $element $thesubdir element] > 0} {
212            set thesubdir ""
213        }
214       
215        if {"$tag" != ""} {
216            eval append element "${thesubdir}:${tag}"
217        } else {
218            eval append element "${thesubdir}"
219        }
220        eval lappend ret $element
221    }
222   
223    return $ret
224}
225
226# Checks sites.
227# sites tags create variables in the portfetch:: namespace containing all sites
228# within that tag distfiles are added in $site $distfile format, where $site is
229# the name of a variable in the portfetch:: namespace containing a list of fetch
230# sites
231proc checksites {args} {
232    global patch_sites master_sites master_sites.mirror_subdir \
233        patch_sites.mirror_subdir fallback_mirror_site global_mirror_site env
234   
235    append master_sites " ${global_mirror_site} ${fallback_mirror_site}"
236    if {[info exists env(MASTER_SITE_LOCAL)]} {
237        set master_sites [concat $env(MASTER_SITE_LOCAL) $master_sites]
238    }
239   
240    append patch_sites " ${global_mirror_site} ${fallback_mirror_site}"
241    if {[info exists env(PATCH_SITE_LOCAL)]} {
242        set patch_sites [concat $env(PATCH_SITE_LOCAL) $patch_sites]
243    }
244
245    foreach list {master_sites patch_sites} {
246        upvar #0 $list uplist
247        if {![info exists uplist]} {
248            continue
249        }
250       
251        set site_list [list]
252        foreach site $uplist {
253            if {[regexp {([a-zA-Z]+://.+)} $site match site]} {
254                set site_list [concat $site_list $site]
255            } else {
256                set splitlist [split $site :]
257                if {[llength $splitlist] > 3 || [llength $splitlist] <1} {
258                    ui_error [format [msgcat::mc "Unable to process mirror sites for: %s, ignoring."] $site]
259                }
260                set mirrors "[lindex $splitlist 0]"
261                set subdir "[lindex $splitlist 1]"
262                set tag "[lindex $splitlist 2]"
263                if {[info exists $list.mirror_subdir]} {
264                    append subdir "[set ${list}.mirror_subdir]"
265                }
266                set site_list [concat $site_list [mirror_sites $mirrors $tag $subdir]]
267            }
268        }
269       
270        # add in the global and fallback mirrors for each tag
271        foreach site $site_list {
272            if {[regexp {([a-zA-Z]+://.+/?):([0-9A-Za-z_-]+)$} $site match site tag]} {
273                if {![info exists extras_added($tag)]} {
274                    set site_list [concat $site_list [mirror_sites $global_mirror_site $tag ""] [mirror_sites $fallback_mirror_site $tag ""]]
275                    if {[string equal $list master_sites] && [info exists env(MASTER_SITE_LOCAL)]} {
276                        set site_list [concat [list $env(MASTER_SITE_LOCAL)] $site_list]
277                    } elseif {[string equal $list patch_sites] && [info exists env(PATCH_SITE_LOCAL)]} {
278                        set site_list [concat [list $env(PATCH_SITE_LOCAL)] $site_list]
279                    }
280                    set extras_added($tag) yes
281                }
282            }
283        }
284       
285        foreach site $site_list {
286            if {[regexp {([a-zA-Z]+://.+/?):([0-9A-Za-z_-]+)$} $site match site tag]} {
287                lappend portfetch::$tag $site
288            } else {
289                lappend portfetch::$list $site
290            }
291        }
292    }
293}
294
295# Checks patch files and their tags to assemble url lists for later fetching
296proc checkpatchfiles {args} {
297    global patchfiles all_dist_files patch_sites fetch_urls filespath
298   
299    if {[info exists patchfiles]} {
300        foreach file $patchfiles {
301            if {![file exists $filespath/$file]} {
302                set distsite [getdisttag $file]
303                set file [getdistname $file]
304                lappend all_dist_files $file
305                if {$distsite != ""} {
306                    lappend fetch_urls $distsite $file
307                } elseif {[info exists patch_sites]} {
308                    lappend fetch_urls patch_sites $file
309                } else {
310                    lappend fetch_urls master_sites $file
311                }
312            }
313        }
314    }
315}
316
317# Checks dist files and their tags to assemble url lists for later fetching
318proc checkdistfiles {args} {
319    global distfiles all_dist_files fetch_urls master_sites filespath
320   
321    if {[info exists distfiles]} {
322    foreach file $distfiles {
323        if {![file exists $filespath/$file]} {
324            set distsite [getdisttag $file]
325            set file [getdistname $file]
326            lappend all_dist_files $file
327            if {$distsite != ""} {
328                lappend fetch_urls $distsite $file
329            } else {
330                lappend fetch_urls master_sites $file
331            }
332        }
333    }
334    }
335}
336
337# sorts fetch_urls in order of ping time
338proc sortsites {args} {
339    global fetch_urls fallback_mirror_site
340
341    set fallback_mirror_list [mirror_sites $fallback_mirror_site {} {}]
342
343    foreach {url_var distfile} $fetch_urls {
344        global portfetch::$url_var
345        if {![info exists $url_var]} {
346            ui_error [format [msgcat::mc "No defined site for tag: %s, using master_sites"] $url_var]
347            set url_var master_sites
348            global portfetch::$url_var
349        }
350        set urllist [set $url_var]
351        set hosts {}
352        set hostregex {[a-zA-Z]+://([a-zA-Z0-9\.\-_]+)}
353
354        if {[llength $urllist] - [llength $fallback_mirror_list] <= 1} {
355            # there is only one mirror, no need to ping or sort
356            continue
357        }
358
359        foreach site $urllist {
360            regexp $hostregex $site -> host
361
362            if { [info exists seen($host)] } {
363                continue
364            }
365            foreach fallback $fallback_mirror_list {
366                if {[string match [append fallback *] $site]} {
367                    # don't bother pinging fallback mirrors
368                    set seen($host) yes
369                    # and make them sort to the very end of the list
370                    set pingtimes($host) 20000
371                    break
372                }
373            }
374            if { ![info exists seen($host)] } {
375                if {[catch {set fds($host) [open "|ping -noq -c3 -t3 $host | grep round-trip | cut -d / -f 5"]}]} {
376                    ui_debug "Spawning ping for $host failed"
377                    # will end up after all hosts that were pinged OK but before those that didn't respond
378                    set pingtimes($host) 5000
379                } else {
380                    ui_debug "Pinging $host..."
381                    set seen($host) yes
382                    lappend hosts $host
383                }
384            }
385        }
386
387        foreach host $hosts {
388            set len [gets $fds($host) pingtimes($host)]
389            if { [catch { close $fds($host) }] || ![string is double -strict $pingtimes($host)] } {
390                # ping failed, so put it last in the list (but before the fallback mirrors)
391                set pingtimes($host) 10000
392            }
393            ui_debug "$host ping time is $pingtimes($host)"
394        }
395       
396        set pinglist {}
397        foreach site $urllist {
398            regexp $hostregex $site -> host
399            lappend pinglist [ list $site $pingtimes($host) ]
400        }
401
402        set pinglist [ lsort -real -index 1 $pinglist ]
403
404        set $url_var {}
405        foreach pair $pinglist {
406            lappend $url_var [lindex $pair 0]
407        }
408    }
409}
410
411# Perform the full checksites/checkpatchfiles/checkdistfiles sequence.
412# This method is used by distcheck target.
413proc checkfiles {args} {
414        # Set fetch_urls to be empty in case there is no file to fetch.
415        global fetch_urls
416        set fetch_urls {}
417        checksites
418        checkpatchfiles
419        checkdistfiles
420}
421
422
423# Perform a CVS login and fetch, storing the CVS login
424# information in a custom .cvspass file
425proc cvsfetch {args} {
426    global workpath cvs.env cvs.cmd cvs.args cvs.post_args
427    global cvs.root cvs.date cvs.tag cvs.password
428    global patch_sites patchfiles filespath
429
430    set cvs.args "co ${cvs.args}"
431    if {[string length ${cvs.tag}]} {
432        set cvs.args "${cvs.args} -r ${cvs.tag}"
433    }
434
435    if {[string length ${cvs.date}]} {
436        set cvs.args "${cvs.args} -D ${cvs.date}"
437    }
438
439    if {[regexp ^:pserver: ${cvs.root}]} {
440        set savecmd ${cvs.cmd}
441        set saveargs ${cvs.args}
442        set savepost_args ${cvs.post_args}
443        set cvs.cmd "echo ${cvs.password} | $portutil::autoconf::cvs_path"
444        set cvs.args login
445        set cvs.post_args ""
446        if {[catch {command_exec cvs -notty "" "2>&1"} result]} {
447            return -code error [msgcat::mc "CVS login failed"]
448        }
449        set cvs.cmd ${savecmd}
450        set cvs.args ${saveargs}
451        set cvs.post_args ${savepost_args}
452    } else {
453        set env(CVS_RSH) ssh
454    }
455
456    if {[catch {command_exec cvs "" "2>&1"} result]} {
457        return -code error [msgcat::mc "CVS check out failed"]
458    }
459
460    if {[info exists patchfiles]} {
461        return [fetchfiles]
462    }
463    return 0
464}
465
466# Perform an svn fetch
467proc svnfetch {args} {
468    global workpath prefix_frozen
469    global svn.env svn.cmd svn.args svn.post_args svn.tag svn.url
470   
471    # Look for the svn command, either in the path or in the prefix
472    set goodcmd 0
473    foreach svncmd "${svn.cmd} ${prefix_frozen}/bin/svn svn" {
474        if { [file executable ${svncmd}] } {
475                  set svn.cmd $svncmd
476                  set goodcmd 1
477              break;
478           }
479    }
480    if { !$goodcmd } {
481        ui_error "The subversion tool (svn) is required to fetch ${svn.url}."
482        ui_error "Please install the subversion port before proceeding."
483                return -code error [msgcat::mc "Subversion check out failed"]
484    }
485   
486    set svn.args "checkout ${svn.args}"
487    if {[string length ${svn.tag}]} {
488                set svn.args "${svn.args} -r ${svn.tag}"
489    }
490
491    if {[catch {command_exec svn "" "2>&1"} result]} {
492                return -code error [msgcat::mc "Subversion check out failed"]
493    }
494
495    if {[info exists patchfiles]} {
496        return [fetchfiles]
497    }
498
499    return 0
500}
501
502# Perform a git fetch
503proc gitfetch {args} {
504    global worksrcpath prefix_frozen
505    global git.url git.branch git.sha1
506   
507    # Look for the git command
508    set git.cmd {}
509    foreach gitcmd "$portutil::autoconf::git_path $prefix_frozen/bin/git git" {
510        if {[file executable $gitcmd]} {
511            set git.cmd $gitcmd
512            break
513        }
514    }
515    if {${git.cmd} == {}} {
516        ui_error "git is required to fetch ${git.url}"
517        ui_error "Please install the git-core port before proceeding."
518        return -code error [msgcat::mc "Git command not found"]
519    }
520   
521    set options "-q"
522    if {[string length ${git.branch}] == 0} {
523        # if we're just using HEAD, we can make a shallow repo
524        set options "$options --depth=1"
525    }
526    set cmdstring "${git.cmd} clone $options ${git.url} ${worksrcpath} 2>&1"
527    ui_debug "Executing: $cmdstring"
528    if {[catch {system $cmdstring} result]} {
529        return -code error [msgcat::mc "Git clone failed"]
530    }
531   
532    if {[string length ${git.branch}] > 0} {
533        set env "GIT_DIR=${worksrcpath}/.git GIT_WORK_TREE=${worksrcpath}"
534        set cmdstring "$env ${git.cmd} checkout -q ${git.branch} 2>&1"
535        ui_debug "Executing $cmdstring"
536        if {[catch {system $cmdstring} result]} {
537            return -code error [msgcat::mc "Git checkout failed"]
538        }
539    }
540   
541    if {[info exists patchfiles]} {
542        return [fetchfiles]
543    }
544   
545    return 0
546}
547
548# Perform a mercurial fetch.
549proc hgfetch {args} {
550    global worksrcpath prefix_frozen
551    global hg.url hg.tag
552
553    # Look for the hg command.
554    set hg.cmd {}
555    foreach hgcmd "$prefix_frozen/bin/hg hg" {
556        if {[file executable $hgcmd]} {
557            set hg.cmd $hgcmd
558            break
559        }
560    }
561    if {${hg.cmd} == {}} {
562        ui_error "hg is required to fetch ${hg.url}"
563        ui_error "Please install the mercurial port before proceeding."
564        return -code error [msgcat::mc "Mercurial command not found"]
565    }
566
567    set cmdstring "${hg.cmd} clone --rev ${hg.tag} ${hg.url} ${worksrcpath} 2>&1"
568    ui_debug "Executing: $cmdstring"
569    if {[catch {system $cmdstring} result]} {
570        return -code error [msgcat::mc "Mercurial clone failed"]
571    }
572
573    if {[info exists patchfiles]} {
574        return [fetchfiles]
575    }
576
577    return 0
578}
579
580# Perform a standard fetch, assembling fetch urls from
581# the listed url variable and associated distfile
582proc fetchfiles {args} {
583        global distpath all_dist_files UI_PREFIX fetch_urls
584        global fetch.user fetch.password fetch.use_epsv fetch.ignore_sslcert fetch.remote_time
585        global distfile site
586        global portverbose
587
588        if {![file isdirectory $distpath]} {
589                if {[catch {file mkdir $distpath} result]} {
590                        return -code error [format [msgcat::mc "Unable to create distribution files path: %s"] $result]
591                }
592        }
593       
594        set fetch_options {}
595        if {[string length ${fetch.user}] || [string length ${fetch.password}]} {
596                lappend fetch_options -u
597                lappend fetch_options "${fetch.user}:${fetch.password}"
598        }
599        if {${fetch.use_epsv} != "yes"} {
600                lappend fetch_options "--disable-epsv"
601        }
602        if {${fetch.ignore_sslcert} != "no"} {
603                lappend fetch_options "--ignore-ssl-cert"
604        }
605        if {${fetch.remote_time} != "no"} {
606                lappend fetch_options "--remote-time"
607        }
608        if {$portverbose == "yes"} {
609                lappend fetch_options "-v"
610        }
611        set sorted no
612       
613        foreach {url_var distfile} $fetch_urls {
614                if {![file isfile $distpath/$distfile]} {
615                        ui_info "$UI_PREFIX [format [msgcat::mc "%s doesn't seem to exist in %s"] $distfile $distpath]"
616                        if {![file writable $distpath]} {
617                                return -code error [format [msgcat::mc "%s must be writable"] $distpath]
618                        }
619                        if {!$sorted} {
620                            sortsites
621                            set sorted yes
622                        }
623                        global portfetch::$url_var
624                        if {![info exists $url_var]} {
625                                ui_error [format [msgcat::mc "No defined site for tag: %s, using master_sites"] $url_var]
626                                set url_var master_sites
627                                global portfetch::$url_var
628                        }
629                        unset -nocomplain fetched
630                        foreach site [set $url_var] {
631                                ui_msg "$UI_PREFIX [format [msgcat::mc "Attempting to fetch %s from %s"] $distfile $site]"
632                                set file_url [portfetch::assemble_url $site $distfile]
633                                set effectiveURL ""
634                                if {![catch {eval curl fetch --effective-url effectiveURL $fetch_options {$file_url} ${distpath}/${distfile}.TMP} result] &&
635                                        ![catch {system "mv ${distpath}/${distfile}.TMP ${distpath}/${distfile}"}]} {
636
637                                        # Special hack to check for sourceforge mirrors, which don't return a proper error code on failure
638                                        if {![string equal $effectiveURL $file_url] &&
639                                                [string match "*sourceforge*" $file_url] &&
640                                                [string match "*failedmirror*" $effectiveURL]} {
641                                               
642                                                # *SourceForge hackage in effect*
643                                                # The url seen by curl seems to have been a redirect to the sourceforge mirror page
644                                                ui_debug "[msgcat::mc "Fetching from sourceforge mirror failed"]"
645                                                exec rm -f ${distpath}/${distfile}.TMP
646                                               
647                                                # Continue on to try the next mirror, if any
648                                        } else {
649                                       
650                                                # Successful fetch
651                                                set fetched 1
652                                                break
653                                       
654                                        }
655
656                                } else {
657                                        ui_debug "[msgcat::mc "Fetching failed:"]: $result"
658                                        exec rm -f ${distpath}/${distfile}.TMP
659                                }
660                        }
661                        if {![info exists fetched]} {
662                                return -code error [msgcat::mc "fetch failed"]
663                        }
664                }
665        }
666    return 0
667}
668
669# Utility function to delete fetched files.
670proc fetch_deletefiles {args} {
671        global distpath fetch_urls
672        foreach {url_var distfile} $fetch_urls {
673                if {[file isfile $distpath/$distfile]} {
674                        exec rm -f ${distpath}/${distfile}
675                }
676        }
677}
678
679# Utility function to add files to a list of fetched files.
680proc fetch_addfilestomap {filemapname} {
681        global distpath fetch_urls $filemapname
682        foreach {url_var distfile} $fetch_urls {
683                if {[file isfile $distpath/$distfile]} {
684                        filemap set $filemapname $distpath/$distfile 1
685                }
686        }
687}
688
689# Initialize fetch target and call checkfiles.
690proc fetch_init {args} {
691    global distfiles distname distpath all_dist_files dist_subdir fetch.type fetch_init_done
692   
693    if {[info exists distpath] && [info exists dist_subdir] && ![info exists fetch_init_done]} {
694            set distpath ${distpath}/${dist_subdir}
695            set fetch_init_done yes
696    }
697    checkfiles
698}
699
700proc fetch_start {args} {
701    global UI_PREFIX portname
702   
703    ui_msg "$UI_PREFIX [format [msgcat::mc "Fetching %s"] $portname]"
704}
705
706# Main fetch routine
707# If all_dist_files is not populated and $fetch.type == standard, then
708# there are no files to download. Otherwise, either do a cvs checkout
709# or call the standard fetchfiles procedure
710proc fetch_main {args} {
711    global distname distpath all_dist_files fetch.type
712
713    # Check for files, download if necessary
714    if {![info exists all_dist_files] && "${fetch.type}" == "standard"} {
715        return 0
716    }
717   
718    # Fetch the files
719    switch -- "${fetch.type}" {
720        cvs             { return [cvsfetch] }
721        svn             { return [svnfetch] }
722        git             { return [gitfetch] }
723        hg              { return [hgfetch] }
724        standard -
725        default { return [fetchfiles] }
726    }
727}
Note: See TracBrowser for help on using the repository browser.