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

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

base: Add support to fetch using Mercurial.

  • 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 40894 2008-10-17 13:33:45Z simon@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 {"${portresourcepath}/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 portresourcepath mirror_sites.listfile mirror_sites.listpath dist_subdir
177    source ${mirror_sites.listpath}${mirror_sites.listfile}
178    if {![info exists portfetch::mirror_sites::sites($mirrors)]} {
179        ui_warn "[format [msgcat::mc "No mirror sites on file for class %s"] $mirrors]"
180        return {}
181    }
182   
183    set ret [list]
184    foreach element $portfetch::mirror_sites::sites($mirrors) {
185       
186        # here we have the chance to take a look at tags, that possibly
187        # have been assigned in mirror_sites.tcl
188        set splitlist [split $element :]
189        # every element is a URL, so we'll always have multiple elements. no need to check
190    set element "[lindex $splitlist 0]:[lindex $splitlist 1]" 
191    set mirror_tag "[lindex $splitlist 2]"
192
193    set name_re {\$(?:name\y|\{name\})}
194    # if the URL has $name embedded, kill any mirror_tag that may have been added
195    # since a mirror_tag and $name are incompatible
196    if {[regexp $name_re $element]} {
197        set mirror_tag ""
198    }
199   
200        if {$mirror_tag == "mirror"} {
201                set thesubdir ${dist_subdir}
202        } elseif {$subdir == "" && $mirror_tag != "nosubdir"} {
203                set thesubdir ${portname}
204        } else {
205                set thesubdir ${subdir}
206        }
207       
208        # parse an embedded $name. if present, remove the subdir
209        if {[regsub $name_re $element $thesubdir element] > 0} {
210            set thesubdir ""
211        }
212       
213        if {"$tag" != ""} {
214            eval append element "${thesubdir}:${tag}"
215        } else {
216            eval append element "${thesubdir}"
217        }
218        eval lappend ret $element
219    }
220   
221    return $ret
222}
223
224# Checks sites.
225# sites tags create variables in the portfetch:: namespace containing all sites
226# within that tag distfiles are added in $site $distfile format, where $site is
227# the name of a variable in the portfetch:: namespace containing a list of fetch
228# sites
229proc checksites {args} {
230    global patch_sites master_sites master_sites.mirror_subdir \
231        patch_sites.mirror_subdir fallback_mirror_site global_mirror_site env
232   
233    append master_sites " ${global_mirror_site} ${fallback_mirror_site}"
234    if {[info exists env(MASTER_SITE_LOCAL)]} {
235        set master_sites [concat $env(MASTER_SITE_LOCAL) $master_sites]
236    }
237   
238    append patch_sites " ${global_mirror_site} ${fallback_mirror_site}"
239    if {[info exists env(PATCH_SITE_LOCAL)]} {
240        set patch_sites [concat $env(PATCH_SITE_LOCAL) $patch_sites]
241    }
242
243    foreach list {master_sites patch_sites} {
244        upvar #0 $list uplist
245        if {![info exists uplist]} {
246            continue
247        }
248       
249        set site_list [list]
250        foreach site $uplist {
251            if {[regexp {([a-zA-Z]+://.+)} $site match site]} {
252                set site_list [concat $site_list $site]
253            } else {
254                set splitlist [split $site :]
255                if {[llength $splitlist] > 3 || [llength $splitlist] <1} {
256                    ui_error [format [msgcat::mc "Unable to process mirror sites for: %s, ignoring."] $site]
257                }
258                set mirrors "[lindex $splitlist 0]"
259                set subdir "[lindex $splitlist 1]"
260                set tag "[lindex $splitlist 2]"
261                if {[info exists $list.mirror_subdir]} {
262                    append subdir "[set ${list}.mirror_subdir]"
263                }
264                set site_list [concat $site_list [mirror_sites $mirrors $tag $subdir]]
265            }
266        }
267       
268        # add in the global and fallback mirrors for each tag
269        foreach site $site_list {
270            if {[regexp {([a-zA-Z]+://.+/?):([0-9A-Za-z_-]+)$} $site match site tag]} {
271                if {![info exists extras_added($tag)]} {
272                    set site_list [concat $site_list [mirror_sites $global_mirror_site $tag ""] [mirror_sites $fallback_mirror_site $tag ""]]
273                    if {[string equal $list master_sites] && [info exists env(MASTER_SITE_LOCAL)]} {
274                        set site_list [concat [list $env(MASTER_SITE_LOCAL)] $site_list]
275                    } elseif {[string equal $list patch_sites] && [info exists env(PATCH_SITE_LOCAL)]} {
276                        set site_list [concat [list $env(PATCH_SITE_LOCAL)] $site_list]
277                    }
278                    set extras_added($tag) yes
279                }
280            }
281        }
282       
283        foreach site $site_list {
284            if {[regexp {([a-zA-Z]+://.+/?):([0-9A-Za-z_-]+)$} $site match site tag]} {
285                lappend portfetch::$tag $site
286            } else {
287                lappend portfetch::$list $site
288            }
289        }
290    }
291}
292
293# Checks patch files and their tags to assemble url lists for later fetching
294proc checkpatchfiles {args} {
295    global patchfiles all_dist_files patch_sites fetch_urls filespath
296   
297    if {[info exists patchfiles]} {
298        foreach file $patchfiles {
299            if {![file exists $filespath/$file]} {
300                set distsite [getdisttag $file]
301                set file [getdistname $file]
302                lappend all_dist_files $file
303                if {$distsite != ""} {
304                    lappend fetch_urls $distsite $file
305                } elseif {[info exists patch_sites]} {
306                    lappend fetch_urls patch_sites $file
307                } else {
308                    lappend fetch_urls master_sites $file
309                }
310            }
311        }
312    }
313}
314
315# Checks dist files and their tags to assemble url lists for later fetching
316proc checkdistfiles {args} {
317    global distfiles all_dist_files fetch_urls master_sites filespath
318   
319    if {[info exists distfiles]} {
320    foreach file $distfiles {
321        if {![file exists $filespath/$file]} {
322            set distsite [getdisttag $file]
323            set file [getdistname $file]
324            lappend all_dist_files $file
325            if {$distsite != ""} {
326                lappend fetch_urls $distsite $file
327            } else {
328                lappend fetch_urls master_sites $file
329            }
330        }
331    }
332    }
333}
334
335# sorts fetch_urls in order of ping time
336proc sortsites {args} {
337    global fetch_urls fallback_mirror_site
338
339    set fallback_mirror_list [mirror_sites $fallback_mirror_site {} {}]
340
341    foreach {url_var distfile} $fetch_urls {
342        global portfetch::$url_var
343        if {![info exists $url_var]} {
344            ui_error [format [msgcat::mc "No defined site for tag: %s, using master_sites"] $url_var]
345            set url_var master_sites
346            global portfetch::$url_var
347        }
348        set urllist [set $url_var]
349        set hosts {}
350        set hostregex {[a-zA-Z]+://([a-zA-Z0-9\.\-_]+)}
351
352        if {[llength $urllist] - [llength $fallback_mirror_list] <= 1} {
353            # there is only one mirror, no need to ping or sort
354            continue
355        }
356
357        foreach site $urllist {
358            regexp $hostregex $site -> host
359
360            if { [info exists seen($host)] } {
361                continue
362            }
363            foreach fallback $fallback_mirror_list {
364                if {[string match [append fallback *] $site]} {
365                    # don't bother pinging fallback mirrors
366                    set seen($host) yes
367                    # and make them sort to the very end of the list
368                    set pingtimes($host) 20000
369                    break
370                }
371            }
372            if { ![info exists seen($host)] } {
373                if {[catch {set fds($host) [open "|ping -noq -c3 -t3 $host | grep round-trip | cut -d / -f 5"]}]} {
374                    ui_debug "Spawning ping for $host failed"
375                    # will end up after all hosts that were pinged OK but before those that didn't respond
376                    set pingtimes($host) 5000
377                } else {
378                    ui_debug "Pinging $host..."
379                    set seen($host) yes
380                    lappend hosts $host
381                }
382            }
383        }
384
385        foreach host $hosts {
386            set len [gets $fds($host) pingtimes($host)]
387            if { [catch { close $fds($host) }] || ![string is double -strict $pingtimes($host)] } {
388                # ping failed, so put it last in the list (but before the fallback mirrors)
389                set pingtimes($host) 10000
390            }
391            ui_debug "$host ping time is $pingtimes($host)"
392        }
393       
394        set pinglist {}
395        foreach site $urllist {
396            regexp $hostregex $site -> host
397            lappend pinglist [ list $site $pingtimes($host) ]
398        }
399
400        set pinglist [ lsort -real -index 1 $pinglist ]
401
402        set $url_var {}
403        foreach pair $pinglist {
404            lappend $url_var [lindex $pair 0]
405        }
406    }
407}
408
409# Perform the full checksites/checkpatchfiles/checkdistfiles sequence.
410# This method is used by distcheck target.
411proc checkfiles {args} {
412        # Set fetch_urls to be empty in case there is no file to fetch.
413        global fetch_urls
414        set fetch_urls {}
415        checksites
416        checkpatchfiles
417        checkdistfiles
418}
419
420
421# Perform a CVS login and fetch, storing the CVS login
422# information in a custom .cvspass file
423proc cvsfetch {args} {
424    global workpath cvs.env cvs.cmd cvs.args cvs.post_args
425    global cvs.root cvs.date cvs.tag cvs.password
426    global patch_sites patchfiles filespath
427
428    set cvs.args "co ${cvs.args}"
429    if {[string length ${cvs.tag}]} {
430        set cvs.args "${cvs.args} -r ${cvs.tag}"
431    }
432
433    if {[string length ${cvs.date}]} {
434        set cvs.args "${cvs.args} -D ${cvs.date}"
435    }
436
437    if {[regexp ^:pserver: ${cvs.root}]} {
438        set savecmd ${cvs.cmd}
439        set saveargs ${cvs.args}
440        set savepost_args ${cvs.post_args}
441        set cvs.cmd "echo ${cvs.password} | $portutil::autoconf::cvs_path"
442        set cvs.args login
443        set cvs.post_args ""
444        if {[catch {command_exec cvs -notty "" "2>&1"} result]} {
445            return -code error [msgcat::mc "CVS login failed"]
446        }
447        set cvs.cmd ${savecmd}
448        set cvs.args ${saveargs}
449        set cvs.post_args ${savepost_args}
450    } else {
451        set env(CVS_RSH) ssh
452    }
453
454    if {[catch {command_exec cvs "" "2>&1"} result]} {
455        return -code error [msgcat::mc "CVS check out failed"]
456    }
457
458    if {[info exists patchfiles]} {
459        return [fetchfiles]
460    }
461    return 0
462}
463
464# Perform an svn fetch
465proc svnfetch {args} {
466    global workpath prefix_frozen
467    global svn.env svn.cmd svn.args svn.post_args svn.tag svn.url
468   
469    # Look for the svn command, either in the path or in the prefix
470    set goodcmd 0
471    foreach svncmd "${svn.cmd} ${prefix_frozen}/bin/svn svn" {
472        if { [file executable ${svncmd}] } {
473                  set svn.cmd $svncmd
474                  set goodcmd 1
475              break;
476           }
477    }
478    if { !$goodcmd } {
479        ui_error "The subversion tool (svn) is required to fetch ${svn.url}."
480        ui_error "Please install the subversion port before proceeding."
481                return -code error [msgcat::mc "Subversion check out failed"]
482    }
483   
484    set svn.args "checkout ${svn.args}"
485    if {[string length ${svn.tag}]} {
486                set svn.args "${svn.args} -r ${svn.tag}"
487    }
488
489    if {[catch {command_exec svn "" "2>&1"} result]} {
490                return -code error [msgcat::mc "Subversion check out failed"]
491    }
492
493    if {[info exists patchfiles]} {
494        return [fetchfiles]
495    }
496
497    return 0
498}
499
500# Perform a git fetch
501proc gitfetch {args} {
502    global worksrcpath prefix_frozen
503    global git.url git.branch git.sha1
504   
505    # Look for the git command
506    set git.cmd {}
507    foreach gitcmd "$portutil::autoconf::git_path $prefix_frozen/bin/git git" {
508        if {[file executable $gitcmd]} {
509            set git.cmd $gitcmd
510            break
511        }
512    }
513    if {${git.cmd} == {}} {
514        ui_error "git is required to fetch ${git.url}"
515        ui_error "Please install the git-core port before proceeding."
516        return -code error [msgcat::mc "Git command not found"]
517    }
518   
519    set options "-q"
520    if {[string length ${git.branch}] == 0} {
521        # if we're just using HEAD, we can make a shallow repo
522        set options "$options --depth=1"
523    }
524    set cmdstring "${git.cmd} clone $options ${git.url} ${worksrcpath} 2>&1"
525    ui_debug "Executing: $cmdstring"
526    if {[catch {system $cmdstring} result]} {
527        return -code error [msgcat::mc "Git clone failed"]
528    }
529   
530    if {[string length ${git.branch}] > 0} {
531        set env "GIT_DIR=${worksrcpath}/.git GIT_WORK_TREE=${worksrcpath}"
532        set cmdstring "$env ${git.cmd} checkout -q ${git.branch} 2>&1"
533        ui_debug "Executing $cmdstring"
534        if {[catch {system $cmdstring} result]} {
535            return -code error [msgcat::mc "Git checkout failed"]
536        }
537    }
538   
539    if {[info exists patchfiles]} {
540        return [fetchfiles]
541    }
542   
543    return 0
544}
545
546# Perform a mercurial fetch.
547proc hgfetch {args} {
548    global worksrcpath prefix_frozen
549    global hg.url hg.tag
550
551    # Look for the hg command.
552    set hg.cmd {}
553    foreach hgcmd "$prefix_frozen/bin/hg hg" {
554        if {[file executable $hgcmd]} {
555            set hg.cmd $hgcmd
556            break
557        }
558    }
559    if {${hg.cmd} == {}} {
560        ui_error "hg is required to fetch ${hg.url}"
561        ui_error "Please install the mercurial port before proceeding."
562        return -code error [msgcat::mc "Mercurial command not found"]
563    }
564
565    set cmdstring "${hg.cmd} clone --rev ${hg.tag} ${hg.url} ${worksrcpath} 2>&1"
566    ui_debug "Executing: $cmdstring"
567    if {[catch {system $cmdstring} result]} {
568        return -code error [msgcat::mc "Mercurial clone failed"]
569    }
570
571    if {[info exists patchfiles]} {
572        return [fetchfiles]
573    }
574
575    return 0
576}
577
578# Perform a standard fetch, assembling fetch urls from
579# the listed url variable and associated distfile
580proc fetchfiles {args} {
581        global distpath all_dist_files UI_PREFIX fetch_urls
582        global fetch.user fetch.password fetch.use_epsv fetch.ignore_sslcert fetch.remote_time
583        global distfile site
584        global portverbose
585
586        if {![file isdirectory $distpath]} {
587                if {[catch {file mkdir $distpath} result]} {
588                        return -code error [format [msgcat::mc "Unable to create distribution files path: %s"] $result]
589                }
590        }
591       
592        set fetch_options {}
593        if {[string length ${fetch.user}] || [string length ${fetch.password}]} {
594                lappend fetch_options -u
595                lappend fetch_options "${fetch.user}:${fetch.password}"
596        }
597        if {${fetch.use_epsv} != "yes"} {
598                lappend fetch_options "--disable-epsv"
599        }
600        if {${fetch.ignore_sslcert} != "no"} {
601                lappend fetch_options "--ignore-ssl-cert"
602        }
603        if {${fetch.remote_time} != "no"} {
604                lappend fetch_options "--remote-time"
605        }
606        if {$portverbose == "yes"} {
607                lappend fetch_options "-v"
608        }
609        set sorted no
610       
611        foreach {url_var distfile} $fetch_urls {
612                if {![file isfile $distpath/$distfile]} {
613                        ui_info "$UI_PREFIX [format [msgcat::mc "%s doesn't seem to exist in %s"] $distfile $distpath]"
614                        if {![file writable $distpath]} {
615                                return -code error [format [msgcat::mc "%s must be writable"] $distpath]
616                        }
617                        if {!$sorted} {
618                            sortsites
619                            set sorted yes
620                        }
621                        global portfetch::$url_var
622                        if {![info exists $url_var]} {
623                                ui_error [format [msgcat::mc "No defined site for tag: %s, using master_sites"] $url_var]
624                                set url_var master_sites
625                                global portfetch::$url_var
626                        }
627                        unset -nocomplain fetched
628                        foreach site [set $url_var] {
629                                ui_msg "$UI_PREFIX [format [msgcat::mc "Attempting to fetch %s from %s"] $distfile $site]"
630                                set file_url [portfetch::assemble_url $site $distfile]
631                                set effectiveURL ""
632                                if {![catch {eval curl fetch --effective-url effectiveURL $fetch_options {$file_url} ${distpath}/${distfile}.TMP} result] &&
633                                        ![catch {system "mv ${distpath}/${distfile}.TMP ${distpath}/${distfile}"}]} {
634
635                                        # Special hack to check for sourceforge mirrors, which don't return a proper error code on failure
636                                        if {![string equal $effectiveURL $file_url] &&
637                                                [string match "*sourceforge*" $file_url] &&
638                                                [string match "*failedmirror*" $effectiveURL]} {
639                                               
640                                                # *SourceForge hackage in effect*
641                                                # The url seen by curl seems to have been a redirect to the sourceforge mirror page
642                                                ui_debug "[msgcat::mc "Fetching from sourceforge mirror failed"]"
643                                                exec rm -f ${distpath}/${distfile}.TMP
644                                               
645                                                # Continue on to try the next mirror, if any
646                                        } else {
647                                       
648                                                # Successful fetch
649                                                set fetched 1
650                                                break
651                                       
652                                        }
653
654                                } else {
655                                        ui_debug "[msgcat::mc "Fetching failed:"]: $result"
656                                        exec rm -f ${distpath}/${distfile}.TMP
657                                }
658                        }
659                        if {![info exists fetched]} {
660                                return -code error [msgcat::mc "fetch failed"]
661                        }
662                }
663        }
664    return 0
665}
666
667# Utility function to delete fetched files.
668proc fetch_deletefiles {args} {
669        global distpath fetch_urls
670        foreach {url_var distfile} $fetch_urls {
671                if {[file isfile $distpath/$distfile]} {
672                        exec rm -f ${distpath}/${distfile}
673                }
674        }
675}
676
677# Utility function to add files to a list of fetched files.
678proc fetch_addfilestomap {filemapname} {
679        global distpath fetch_urls $filemapname
680        foreach {url_var distfile} $fetch_urls {
681                if {[file isfile $distpath/$distfile]} {
682                        filemap set $filemapname $distpath/$distfile 1
683                }
684        }
685}
686
687# Initialize fetch target and call checkfiles.
688proc fetch_init {args} {
689    global distfiles distname distpath all_dist_files dist_subdir fetch.type fetch_init_done
690   
691    if {[info exists distpath] && [info exists dist_subdir] && ![info exists fetch_init_done]} {
692            set distpath ${distpath}/${dist_subdir}
693            set fetch_init_done yes
694    }
695    checkfiles
696}
697
698proc fetch_start {args} {
699    global UI_PREFIX portname
700   
701    ui_msg "$UI_PREFIX [format [msgcat::mc "Fetching %s"] $portname]"
702}
703
704# Main fetch routine
705# If all_dist_files is not populated and $fetch.type == standard, then
706# there are no files to download. Otherwise, either do a cvs checkout
707# or call the standard fetchfiles procedure
708proc fetch_main {args} {
709    global distname distpath all_dist_files fetch.type
710
711    # Check for files, download if necessary
712    if {![info exists all_dist_files] && "${fetch.type}" == "standard"} {
713        return 0
714    }
715   
716    # Fetch the files
717    switch -- "${fetch.type}" {
718        cvs             { return [cvsfetch] }
719        svn             { return [svnfetch] }
720        git             { return [gitfetch] }
721        hg              { return [hgfetch] }
722        standard -
723        default { return [fetchfiles] }
724    }
725}
Note: See TracBrowser for help on using the repository browser.