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

Last change on this file since 3108 was 3108, checked in by landonf (Landon Fuller), 17 years ago

Remove freebsd-specific check
freebsd users will now require curl

  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 10.8 KB
Line 
1# et:ts=4
2# portfetch.tcl
3#
4# Copyright (c) 2002 - 2003 Apple Computer, Inc.
5# All rights reserved.
6#
7# Redistribution and use in source and binary forms, with or without
8# modification, are permitted provided that the following conditions
9# are met:
10# 1. Redistributions of source code must retain the above copyright
11#    notice, this list of conditions and the following disclaimer.
12# 2. Redistributions in binary form must reproduce the above copyright
13#    notice, this list of conditions and the following disclaimer in the
14#    documentation and/or other materials provided with the distribution.
15# 3. Neither the name of Apple Computer, Inc. nor the names of its contributors
16#    may be used to endorse or promote products derived from this software
17#    without specific prior written permission.
18#
19# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
20# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
21# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
22# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
23# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
24# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
25# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
26# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
27# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
28# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
29# POSSIBILITY OF SUCH DAMAGE.
30#
31
32package provide portfetch 1.0
33package require portutil 1.0
34
35set com.apple.fetch [target_new com.apple.fetch fetch_main]
36target_init ${com.apple.fetch} fetch_init
37target_provides ${com.apple.fetch} fetch
38target_requires ${com.apple.fetch} main
39target_prerun ${com.apple.fetch} fetch_start
40
41# define options: distname master_sites
42options master_sites patch_sites extract.sufx distfiles patchfiles use_zip use_bzip2 dist_subdir fetch.type cvs.module cvs.root cvs.password cvs.tag master_sites.mirror_subdir patch_sites.mirror_subdir
43# XXX we use the command framework to buy us some useful features,
44# but this is not a user-modifiable command
45commands cvs
46commands fetch
47
48# Defaults
49default extract.sufx .tar.gz
50default fetch.type standard
51default cvs.cmd cvs
52default cvs.password ""
53default cvs.dir {${workpath}}
54default cvs.module {$distname}
55default cvs.tag HEAD
56default cvs.env {CVS_PASSFILE=${workpath}/.cvspass}
57default cvs.pre_args {"-d ${cvs.root}"}
58
59default fetch.cmd curl
60default fetch.dir {${distpath}}
61default fetch.args {"-o ${distfile}.TMP"}
62default fetch.pre_args ""
63default fetch.post_args {"${site}/${distfile}"}
64
65default mirror_sites.listfile {"mirror_sites.tcl"}
66default mirror_sites.listpath {"${portresourcepath}/fetch/"}
67
68# Set distfiles
69default distfiles {[suffix $distname]}
70
71# Option-executed procedures
72namespace eval options { }
73proc options::use_bzip2 {args} {
74    global use_bzip2 extract.sufx
75    if [tbool use_bzip2] {
76        set extract.sufx .tar.bz2
77    }
78}
79
80proc options::use_zip {args} {
81    global use_zip extract.sufx
82    if [tbool use_zip] {
83        set extract.sufx .zip
84    }
85}
86
87# Name space for internal implementation variables
88# Site lists are stored here
89namespace eval portfetch { }
90
91set UI_PREFIX "---> "
92
93# Given a distname, return a suffix based on the use_zip / use_bzip2 / extract.sufx options
94proc suffix {distname} {
95    global extract.sufx use_bzip2 use_zip fetch.type
96    if {"${fetch.type}" == "cvs"} {
97        return ""
98    }
99    if {[tbool use_bzip2]} {
100        return ${distname}.tar.bz2
101    } elseif {[tbool use_zip]} {
102        return ${distname}.zip
103    } else {
104        return ${distname}${extract.sufx}
105    }
106}
107
108# Given a distribution file name, return the appended tag
109# Example: getdisttag distfile.tar.gz:tag1 returns "tag1"
110proc getdisttag {name} {
111    if {[regexp {.+:([A-Za-z]+)} $name match tag]} {
112        return $tag
113    } else {
114        return ""
115    }
116}
117
118# Given a distribution file name, return the name without an attached tag
119# Example : getdistname distfile.tar.gz:tag1 returns "distfile.tar.gz"
120proc getdistname {name} {
121    regexp {(.+):[A-Za-z_-]+} $name match name
122    return $name
123}
124
125# XXX
126# Helper function for portextract.tcl that strips all tag names from a list
127# Used to clean ${distfiles} for setting the ${extract.only} default
128proc disttagclean {list} {
129    if {"$list" == ""} {
130        return $list
131    }
132    foreach name $list {
133        lappend val [getdistname $name]
134    }
135    return $val
136}
137
138# For a given mirror site type, e.g. "gnu" or "x11", check to see if there's a
139# pre-registered set of sites, and if so, return them.
140proc mirror_sites {mirrors tag subdir} {
141    global UI_PREFIX portresourcepath mirror_sites.listfile mirror_sites.listpath
142    include ${mirror_sites.listpath}${mirror_sites.listfile}
143    if ![info exists portfetch::mirror_sites::sites($mirrors)] {
144        ui_warn "[format [msgcat::mc "No mirror sites on file for class %s"] $mirrors]"
145        return {}
146    }
147   
148    set ret [list]
149    foreach element $portfetch::mirror_sites::sites($mirrors) {
150        if {"$tag" != ""} {
151            eval append element "${subdir}/:${tag}"
152        } else {
153            eval append element "${subdir}/"
154        }
155        eval lappend ret $element
156    }
157    return $ret
158}
159
160# Checks all files and their tags to assemble url lists for later fetching
161# sites tags create variables in the portfetch:: namespace containing all sites
162# within that tag distfiles are added in $site $distfile format, where $site is
163# the name of a variable in the portfetch:: namespace containing a list of fetch
164# sites
165proc checkfiles {args} {
166    global distdir distfiles patchfiles all_dist_files patch_sites fetch_urls \
167        master_sites filespath master_sites.mirror_subdir \
168        patch_sites.mirror_subdir
169
170    foreach list {master_sites patch_sites} {
171        upvar #0 $list uplist
172        if ![info exists uplist] {
173            continue
174        }
175       
176        set site_list [list]
177        foreach site $uplist {
178            if {[regexp {([a-zA-Z]+://.+)} $site match site] == 1} {
179                set site_list [concat $site_list $site]
180            } else {
181                set splitlist [split $site :]
182                if {[llength $splitlist] > 3 || [llength $splitlist] <1} {
183                    ui_error [format [msgcat::mc "Unable to process mirror sites for: %s, ignoring."] $site]
184                }
185                set mirrors "[lindex $splitlist 0]"
186                set subdir "[lindex $splitlist 1]"
187                set tag "[lindex $splitlist 2]"
188                if [info exists $list.mirror_subdir] {
189                    append subdir "/[set ${list}.mirror_subdir]"
190                }
191                set site_list [concat $site_list [mirror_sites $mirrors $tag $subdir]]
192            }
193        }
194       
195        foreach site $site_list {
196            if {[regexp {([a-zA-Z]+://.+/):([a-zA-Z]+)} $site match site tag] == 1} {
197                lappend portfetch::$tag $site
198            } else {
199                lappend portfetch::$list $site
200            }
201        }
202    }
203   
204    if {[info exists patchfiles]} {
205        foreach file $patchfiles {
206            if {![file exists $filespath/$file]} {
207                set distsite [getdisttag $file]
208                set file [getdistname $file]
209                lappend all_dist_files $file
210                if {$distsite != ""} {
211                    lappend fetch_urls $distsite $file
212                } elseif {[info exists patch_sites]} {
213                    lappend fetch_urls patch_sites $file
214                } else {
215                    lappend fetch_urls master_sites $file
216                }
217            }
218        }
219    }
220   
221    foreach file $distfiles {
222        if {![file exists $filespath/$file]} {
223            set distsite [getdisttag $file]
224            set file [getdistname $file]
225            lappend all_dist_files $file
226            if {$distsite != ""} {
227                lappend fetch_urls $distsite $file
228            } else {
229                lappend fetch_urls master_sites $file
230            }
231        }
232    }
233}
234
235# Perform a CVS login and fetch, storing the CVS login
236# information in a custom .cvspass file
237proc cvsfetch {args} {
238    global workpath cvs.password cvs.args cvs.post_args cvs.tag cvs.module cvs.cmd cvs.env
239    cd $workpath
240    set cvs.args login
241    set cvs.cmd "echo ${cvs.password} | /usr/bin/env ${cvs.env} cvs"
242    if {[catch {system "[command cvs] 2>&1"} result]} {
243        return -code error [msgcat::mc "CVS login failed"]
244    }
245    set cvs.args "co -r ${cvs.tag}"
246    set cvs.cmd cvs
247    set cvs.post_args "${cvs.module}"
248    if {[catch {system "[command cvs] 2>&1"} result]} {
249        return -code error [msgcat::mc "CVS check out failed"]
250    }
251    return 0
252}
253
254# Perform a standard fetch, assembling fetch urls from
255# the listed url varable and associated distfile
256proc fetchfiles {args} {
257    global distpath all_dist_files UI_PREFIX fetch_urls fetch.cmd os.platform fetch.pre_args
258    global distfile site
259
260    if {![file isdirectory $distpath]} {
261        if {[catch {file mkdir $distpath} result]} {
262            return -code error [format [msgcat::mc "Unable to create distribution files path: %s"] $result]
263        }
264    }
265    if {![file writable $distpath]} {
266        return -code error [format [msgcat::mc "%s must be writable"] $distpath]
267    }
268    foreach {url_var distfile} $fetch_urls {
269        if {![file isfile $distpath/$distfile]} {
270            ui_info "$UI_PREFIX [format [msgcat::mc "%s doesn't seem to exist in %s"] $distfile $distpath]"
271            global portfetch::$url_var
272            if ![info exists $url_var] {
273                ui_error [format [msgcat::mc "No defined site for tag: %s, using master_sites"] $url_var]
274                set url_var master_sites
275                global portfetch::$url_var
276            }
277            foreach site [set $url_var] {
278                ui_msg "$UI_PREFIX [format [msgcat::mc "Attempting to fetch %s from %s"] $distfile $site]"
279                if {![catch {system "[command fetch]"} result] &&
280                    ![catch {system "mv ${distpath}/${distfile}.TMP ${distpath}/${distfile}"}]} {
281                    set fetched 1
282                    break
283                } else {
284                    exec rm -f ${distpath}/${distfile}.TMP
285                    ui_error "[msgcat::mc "Unable to fetch:"]: $result"
286                }
287            }
288            if {![info exists fetched]} {
289                return -code error [msgcat::mc "fetch failed"]
290            } else {
291                unset fetched
292            }
293        }
294    }
295    return 0
296}
297
298# Initialize fetch target, calling checkfiles if neccesary
299proc fetch_init {args} {
300    global distfiles distname distpath all_dist_files dist_subdir fetch.type
301
302    if {[info exist distpath] && [info exists dist_subdir]} {
303        set distpath ${distpath}/${dist_subdir}
304    }
305    if {"${fetch.type}" == "standard"} {
306        checkfiles
307    }
308}
309
310proc fetch_start {args} {
311    global UI_PREFIX portname
312
313    ui_msg "$UI_PREFIX [format [msgcat::mc "Fetching %s"] $portname]"
314}
315
316# Main fetch routine
317# If all_dist_files is not populated and $fetch.type == standard, then
318# there are no files to download. Otherwise, either do a cvs checkout
319# or call the standard fetchfiles procedure
320proc fetch_main {args} {
321    global distname distpath all_dist_files fetch.type
322
323    # Check for files, download if neccesary
324    if {![info exists all_dist_files] && "${fetch.type}" == "standard"} {
325        return 0
326    }
327    if {"${fetch.type}" == "cvs"} {
328        return [cvsfetch]
329    } else {
330        return [fetchfiles]
331    }
332}
Note: See TracBrowser for help on using the repository browser.