source: trunk/base/src/port1.0/fetch_common.tcl @ 106614

Last change on this file since 106614 was 106614, checked in by jmr@…, 7 years ago

combine multiple adjacent calls to global

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 12.4 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# $Id: fetch_common.tcl 106614 2013-06-01 05:12:02Z jmr@macports.org $
3#
4# Copyright (c) 2002 - 2003 Apple Inc.
5# Copyright (c) 2004 - 2013 The MacPorts Project
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 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
32package provide fetch_common 1.0
33package require portutil 1.0
34package require Pextlib 1.0
35
36namespace eval portfetch {
37    variable urlmap
38    array set urlmap {}
39}
40
41# Name space for internal site lists storage
42namespace eval portfetch::mirror_sites {
43    variable sites
44
45    array set sites {}
46}
47
48# percent-encode all characters in str that are not unreserved in URIs
49proc portfetch::percent_encode {str} {
50    set outstr ""
51    while {[string length $str] > 0} {
52        set char [string index $str 0]
53        set str [string range $str 1 end]
54        switch -- $char {
55            {-} -
56            {.} -
57            {_} -
58            {~} {
59                append outstr $char
60            }
61            default {
62                if {[string is ascii -strict $char] && [string is alnum -strict $char]} {
63                    append outstr $char
64                } else {
65                    foreach {a b} [split [format %02X [scan $char %c]] {}] {
66                        append outstr "%${a}${b}"
67                    }
68                }
69            }
70        }
71    }
72    return $outstr
73}
74
75# Given a site url and the name of the distfile, assemble url and
76# return it.
77proc portfetch::assemble_url {site distfile} {
78    if {[string index $site end] != "/"} {
79        append site /
80    }
81    return "${site}[percent_encode ${distfile}]"
82}
83
84# For a given mirror site type, e.g. "gnu" or "x11", check to see if there's a
85# pre-registered set of sites, and if so, return them.
86proc portfetch::mirror_sites {mirrors tag subdir mirrorfile} {
87    global UI_PREFIX name dist_subdir \
88           global_mirror_site fallback_mirror_site
89
90    if {[file exists $mirrorfile]} {
91        source $mirrorfile
92    }
93
94    if {![info exists portfetch::mirror_sites::sites($mirrors)]} {
95        if {$mirrors != $global_mirror_site && $mirrors != $fallback_mirror_site} {
96            ui_warn "[format [msgcat::mc "No mirror sites on file for class %s"] $mirrors]"
97        }
98        return {}
99    }
100
101    set ret [list]
102    foreach element $portfetch::mirror_sites::sites($mirrors) {
103
104        # here we have the chance to take a look at tags, that possibly
105        # have been assigned in mirror_sites.tcl
106        # tag will be after the last colon after the
107        # first slash after the ://
108        set lastcolon [string last : $element]
109        set aftersep [expr [string first : $element] + 3]
110        set firstslash [string first / $element $aftersep]
111        if {$firstslash != -1 && $firstslash < $lastcolon} {
112            set mirror_tag [string range $element [expr $lastcolon + 1] end]
113            set element [string range $element 0 [expr $lastcolon - 1]]
114        } else {
115            set mirror_tag ""
116        }
117
118        set name_re {\$(?:name\y|\{name\})}
119        # if the URL has $name embedded, kill any mirror_tag that may have been added
120        # since a mirror_tag and $name are incompatible
121        if {[regexp $name_re $element]} {
122            set mirror_tag ""
123        }
124
125        if {$mirror_tag == "mirror"} {
126            set thesubdir ${dist_subdir}
127        } elseif {$subdir == "" && $mirror_tag != "nosubdir"} {
128            set thesubdir ${name}
129        } else {
130            set thesubdir ${subdir}
131        }
132
133        # parse an embedded $name. if present, remove the subdir
134        if {[regsub $name_re $element $thesubdir element] > 0} {
135            set thesubdir ""
136        }
137
138        if {"$tag" != ""} {
139            eval append element "${thesubdir}:${tag}"
140        } else {
141            eval append element "${thesubdir}"
142        }
143
144        eval lappend ret $element
145    }
146
147    return $ret
148}
149
150# Checks sites.
151# sites tags create variables in the portfetch:: namespace containing all sites
152# within that tag distfiles are added in $site $distfile format, where $site is
153# the name of a variable in the portfetch:: namespace containing a list of fetch
154# sites
155proc portfetch::checksites {sitelists mirrorfile} {
156    global env
157    variable urlmap
158
159    foreach {listname extras} $sitelists {
160        upvar #0 $listname $listname
161        if {![info exists $listname]} {
162            continue
163        }
164        global ${listname}.mirror_subdir
165        # add the specified global, fallback and user-defined mirrors
166        set sglobal [lindex $extras 0]; set sfallback [lindex $extras 1]; set senv [lindex $extras 2]
167        set full_list [set $listname]
168        append full_list " $sglobal $sfallback"
169        if {[info exists env($senv)]} {
170            set full_list [concat $env($senv) $full_list]
171        }
172
173        set site_list [list]
174        foreach site $full_list {
175            if {[regexp {([a-zA-Z]+://.+)} $site match site]} {
176                set site_list [concat $site_list $site]
177            } else {
178                set splitlist [split $site :]
179                if {[llength $splitlist] > 3 || [llength $splitlist] <1} {
180                    ui_error [format [msgcat::mc "Unable to process mirror sites for: %s, ignoring."] $site]
181                }
182                set mirrors "[lindex $splitlist 0]"
183                set subdir "[lindex $splitlist 1]"
184                set tag "[lindex $splitlist 2]"
185                if {[info exists ${listname}.mirror_subdir]} {
186                    append subdir "[set ${listname}.mirror_subdir]"
187                }
188                set site_list [concat $site_list [mirror_sites $mirrors $tag $subdir $mirrorfile]]
189            }
190        }
191
192        # add in the global, fallback and user-defined mirrors for each tag
193        foreach site $site_list {
194            if {[regexp {([a-zA-Z]+://.+/?):([0-9A-Za-z_-]+)$} $site match site tag] && ![info exists extras_added($tag)]} {
195                if {$sglobal != ""} {
196                    set site_list [concat $site_list [mirror_sites $sglobal $tag "" $mirrorfile]]
197                }
198                if {$sfallback != ""} {
199                    set site_list [concat $site_list [mirror_sites $sfallback $tag "" $mirrorfile]]
200                }
201                if {[info exists env($senv)]} {
202                    set site_list [concat [list $env($senv)] $site_list]
203                }
204                set extras_added($tag) yes
205            }
206        }
207
208        foreach site $site_list {
209        if {[regexp {([a-zA-Z]+://.+/?):([0-9A-Za-z_-]+)$} $site match site tag]} {
210                lappend urlmap($tag) $site
211            } else {
212                lappend urlmap($listname) $site
213            }
214        }
215    }
216}
217
218# sorts fetch_urls in order of ping time
219proc portfetch::sortsites {urls fallback_mirror_list default_listvar} {
220    global $default_listvar
221    upvar $urls fetch_urls
222    variable urlmap
223
224    foreach {url_var distfile} $fetch_urls {
225        if {![info exists urlmap($url_var)]} {
226            if {$url_var != $default_listvar} {
227                ui_error [format [msgcat::mc "No defined site for tag: %s, using $default_listvar"] $url_var]
228                set urlmap($url_var) $urlmap($default_listvar)
229            } else {
230                set urlmap($url_var) {}
231            }
232        }
233        set urllist $urlmap($url_var)
234        set hosts {}
235        set hostregex {[a-zA-Z]+://([a-zA-Z0-9\.\-_]+)}
236
237        if {[llength $urllist] - [llength $fallback_mirror_list] <= 1} {
238            # there is only one mirror, no need to ping or sort
239            continue
240        }
241
242        # can't do the ping with dropped privileges (though it works fine if we didn't start as root)
243        if {[getuid] == 0 && [geteuid] != 0} {
244            set oldeuid [geteuid]
245            set oldegid [getegid]
246            seteuid 0; setegid 0
247        }
248
249        foreach site $urllist {
250            if {[string range $site 0 6] == "file://"} {
251                set pingtimes(localhost) 0
252                continue
253            }
254           
255            regexp $hostregex $site -> host
256           
257            if { [info exists seen($host)] } {
258                continue
259            }
260            foreach fallback $fallback_mirror_list {
261                if {[string match ${fallback}* $site]} {
262                    # don't bother pinging fallback mirrors
263                    set seen($host) yes
264                    # and make them sort to the very end of the list
265                    set pingtimes($host) 20000
266                    break
267                }
268            }
269            if { ![info exists seen($host)] } {
270                # first check the persistent cache
271                set pingtimes($host) [get_pingtime $host]
272                if {$pingtimes($host) == {}} {
273                    if {[catch {set fds($host) [open "|ping -noq -c3 -t3 $host | grep round-trip | cut -d / -f 5"]}]} {
274                        ui_debug "Spawning ping for $host failed"
275                        # will end up after all hosts that were pinged OK but before those that didn't respond
276                        set pingtimes($host) 5000
277                    } else {
278                        set seen($host) yes
279                        lappend hosts $host
280                    }
281                }
282            }
283        }
284
285        foreach host $hosts {
286            gets $fds($host) pingtimes($host)
287            if { [catch { close $fds($host) }] || ![string is double -strict $pingtimes($host)] } {
288                # ping failed, so put it last in the list (but before the fallback mirrors)
289                set pingtimes($host) 10000
290            }
291            # cache it
292            set_pingtime $host $pingtimes($host)
293        }
294
295        if {[info exists oldeuid]} {
296            setegid $oldegid
297            seteuid $oldeuid
298        }
299
300        set pinglist {}
301        foreach site $urllist {
302            if {[string range $site 0 6] == "file://"} {
303                set host localhost
304            } else {
305                regexp $hostregex $site -> host
306            }
307            # -1 means blacklisted
308            if {$pingtimes($host) != "-1"} {
309                lappend pinglist [ list $site $pingtimes($host) ]
310            }
311        }
312
313        set pinglist [ lsort -real -index 1 $pinglist ]
314
315        set urlmap($url_var) {}
316        foreach pair $pinglist {
317            lappend urlmap($url_var) [lindex $pair 0]
318        }
319    }
320}
321
322proc portfetch::get_urls {} {
323    variable fetch_urls
324    variable urlmap
325    set urls {}
326
327    portfetch::checkfiles fetch_urls
328
329    foreach {url_var distfile} $fetch_urls {
330        if {![info exists urlmap($url_var)]} {
331            ui_error [format [msgcat::mc "No defined site for tag: %s, using master_sites"] $url_var]
332            set urlmap($url_var) $urlmap(master_sites)
333        }
334        foreach site $urlmap($url_var) {
335            lappend urls $site
336        }
337    }
338
339    return $urls
340}
341
342# warn if DNS is broken
343proc portfetch::check_dns {} {
344    # check_broken_dns returns true at most once, so we don't have to worry about spamming this message
345    if {[check_broken_dns]} {
346        ui_warn "Your DNS servers incorrectly claim to know the address of nonexistent hosts. This may cause checksum mismatches for some ports."
347    }
348}
Note: See TracBrowser for help on using the repository browser.