source: project/chicken/branches/hygienic/setup-download.scm @ 11524

Last change on this file since 11524 was 11524, checked in by felix winkelmann, 12 years ago

re-loading imported module into interpreter incorrectly renamed export list (export-lists are now sytax-stripped); started with guerilla setup

File size: 2.8 KB
Line 
1;;;; setup-download.scm
2
3
4(require-library extras regex posix utils setup-utils srfi-1 data-structures)
5
6
7(module setup-download (retrieve-extension
8                        locate-egg/local
9                        locate-egg/svn
10                        locate-egg/http)
11
12  (import scheme chicken)
13  (import extras regex posix utils setup-utils srfi-1 data-structures)
14
15  (define (locate-egg/local egg dir #!optional version)
16    (let* ((eggdir (make-pathname dir egg))
17           (files (directory eggdir))
18           (trunkdir (make-pathname eggdir "trunk"))
19           (tagdir (make-pathname eggdir "tags"))
20           (hastrunk (and (file-exists? trunkdir) (directory? trunkdir))))
21      (or (and (file-exists? tagdir) (directory? tagdir)
22               (let ((vs (directory tagdir)))
23                 (if version
24                     (if (member version vs)
25                         (make-pathname tagdir version)
26                         (error "version not found" egg version))
27                     (let ((vs (sort vs version>=?)))
28                       (and (pair? vs)
29                            (make-pathname tagdir (car vs)))))))
30          (begin
31            (when version
32              (warning "extension has no such version - using trunk" egg version))
33            (or (and hastrunk trunkdir)
34                eggdir)))))
35
36  (define (locate-egg/svn egg repo #!optional version)
37    (let* ((files
38            (with-input-from-pipe 
39             (sprintf "svn ls -R '~a/~a'" repo egg)
40             read-lines))
41           (hastrunk (member "trunk/" files)) 
42           (filedir
43            (or (let ((vs (filter-map
44                           (lambda (f)
45                             (and-let* ((m (string-search "^tags/([^/]+)/" f)))
46                               (cadr m)))
47                           files)))
48                  (if version
49                      (if (member version vs)
50                          (string-append "tags/" version)
51                          (error "version not found" egg version))
52                      (let ((vs (sort vs version>=?)))
53                        (and (pair? vs)
54                             (string-append "tags/" (car vs))))))
55                (begin
56                  (when version
57                    (warning "extension has no such version - using trunk" egg version))
58                  (and hastrunk "trunk") )
59                ""))
60           (tmpdir (create-temporary-directory))
61           (cmd (sprintf "svn co '~a/~a/~a' '~a'" repo egg filedir tmpdir)))
62      (print "  " cmd)
63      (system* cmd)
64      tmpdir))
65
66  (define (locate-egg/http egg url #!optional version)
67    (let* ((tmpdir (create-temporary-directory))
68           (m (string-match "([^/]+)(:([^:/]+))?(/.+)" url))
69           (host (if m (cadr m) url))
70           (port (if (and m (caddr m)) 
71                     (or (string->number (cadddr m)) 
72                         (error "not a valid port" (cadddr m)))
73                     80))
74           (loc (string-append
75                 (if m (list-ref m 4) "/")
76                 (if version
77                     (string-append "?version=" version)
78                     ""))))
79      (http-fetch host port loc tmpdir)
80      tmpdir))
81
82  (define (retrieve-extension name transport location #!optional version)
83    (case transport
84      ((local) 
85       (values (locate-egg/local name location version) #f) )
86      ((svn)
87       (values (locate-egg/svn name location version) #t) )
88      ((http)
89       (values (locate-egg/http name location version) #t) )
90      (else (error "unsupported transport" transport))))
91
92)
Note: See TracBrowser for help on using the repository browser.