source: project/release/5/srfi-29/tags/3.0.2/srfi-29-install.scm @ 38538

Last change on this file since 38538 was 38538, checked in by Kon Lovett, 16 months ago

rel 3.0.2

File size: 6.3 KB
Line 
1;;;; srfi-29-install.scm
2;;;; Kon Lovett, Oct '19
3
4;; Issues
5;;
6
7(declare
8  (bound-to-procedure
9    ##sys#check-syntax
10    ##sys#signal-hook))
11
12(module srfi-29-install
13
14(;export
15  system-bundle-directory
16  install-bundle)
17
18(import scheme)
19(import (chicken base))
20(import (chicken type))
21(import (chicken syntax))
22(import (chicken platform))
23(import (chicken pathname))
24(import (chicken file))
25(import (srfi 1))
26(import utf8)
27(import utf8-srfi-13)
28(import (only type-errors error-argument-type warning-argument-type))
29
30;;; Dependency Neurosis
31
32;;(only miscmacros define-parameter
33
34(define-syntax define-parameter
35  (syntax-rules ()
36    ((define-parameter name value guard)
37     (define name (make-parameter value guard)))
38    ((define-parameter name value)
39     (define name (make-parameter value)))
40    ((define-parameter name)
41     (define name (make-parameter (void))))))
42
43;;(only numeric-macros one?)
44
45(define-syntax one? (syntax-rules () ((one? ?n) (= 1 ?n))))
46
47;;(only moremacros ->boolean define-warning-parameter)
48
49(define-syntax ->boolean (syntax-rules () ((->boolean ?obj) (and ?obj #t))))
50
51(import-for-syntax (only (chicken string) conc))
52
53(define-for-syntax (make-identifier . elts)
54  (string->symbol (apply conc (map strip-syntax elts))) )
55
56(define-syntax define-warning-parameter
57  (syntax-rules ()
58    ((define-warning-parameter ?name ?init ?typnam ?body0 ...)
59      (define-parameter ?name ?init (warning-guard ?name ?typnam ?body0 ...)) ) ) )
60
61(define-syntax warning-guard
62  (er-macro-transformer
63    (lambda (frm rnm cmp)
64      (##sys#check-syntax 'warning-guard frm '(_ symbol symbol . _))
65      (let (
66        (?getnam (cadr frm))
67        (?typnam (caddr frm))
68        (?body (cdddr frm))
69        (_lambda (rnm 'lambda))
70        (_if (rnm 'if))
71        (_begin (rnm 'begin))
72        (_warning-argument-type (rnm 'warning-argument-type)) )
73        (let (
74          (predname (make-identifier (symbol->string ?typnam) "?")) )
75          `(,_lambda (obj)
76            (,_if (,predname obj)
77              (,_begin
78                ,@?body
79                obj)
80              (,_begin
81                (,_warning-argument-type ',?getnam obj ',?typnam)
82                (,?getnam) ) ) ) ) ) ) ) )
83
84;;; Utilities
85
86(define (->symbol obj) (string->symbol (->string obj)))
87
88(include-relative "locale-item")
89
90#; ;UNUSED
91(define-check+error-type locale-item)
92
93;;;
94
95;; Simple type error report
96
97(define (sh:error-type loc obj #!optional typmsg)
98  (let* (
99    (msg "bad argument type")
100    (msg (if typmsg (string-append msg "; not a " typmsg) msg)) )
101    (##sys#signal-hook #:type-error loc msg obj) ) )
102
103;;;
104
105(cond-expand
106  (windows
107    ;(define-constant EXECUTABLE-EXTN "exe")
108    (define-constant DIRECTORY-SEP "\\") )
109  (else
110    ;(define-constant EXECUTABLE-EXTN #f)
111    (define-constant DIRECTORY-SEP "/") ) )
112
113;; File Mode Support
114
115#|
116#; ;UNUSED
117;mod is a symbol, ex: 'a+r
118(define (file-chmod pn mod)
119  (cond-expand
120    (windows
121      (void) )
122    (else
123      (run (,(if (sudo-install) "sudo chmod" "chmod") ,mod ,(shellpath pn))) ) ) )
124
125(define perm:a+r (bitwise-ior perm/irusr perm/irgrp perm/iroth))
126(define perm:a+x (bitwise-ior perm/ixusr perm/ixgrp perm/ixoth))
127(define perm:a+rx (bitwise-ior perm:a+r perm:a+x))
128
129(define (file-chmod pn perm)
130  (cond-expand
131    (windows
132      (void) )
133    (else
134      (import synch-dynexn)
135      (let* (
136        (perm (symbolic->unix-permissions perm))
137        (fn (file-open pn open/rdonly perm)) )
138          (set! (file-permissions fn) perm)
139      (file-close fn) ) ) ) )
140|#
141
142;;
143
144(define-type pathname string)
145
146(: pathname? (* -> boolean : string))
147(define (pathname? obj)
148  (and
149    (string? obj)
150    (let-values (((dir fil ext) (decompose-pathname obj)))
151      ;ext w/o dir/fil indicates a *nix "hidden" file (too broad for Windows?)
152      (->boolean (or dir fil ext)) ) ) )
153
154(define (directory-separator) DIRECTORY-SEP)
155
156(define (directory-separator? obj)
157  (string=? (directory-separator) (->string obj)) )
158
159(define (trim-directory-separator dir)
160  (if (string-suffix? (directory-separator) dir)
161    (string-drop-right dir (string-length (directory-separator)))
162    dir ) )
163
164(define (make-home-pathname bn)
165  (make-pathname (chicken-home) bn) )
166
167(define (make-directory-name dir)
168  (let (
169    (dir (if (atom? dir) (->string dir) (map ->string dir))) )
170    ;Ensures no trailing directory separator.
171    (cond
172      ((string? dir)
173        (trim-directory-separator dir) )
174      ((pair? dir)
175        (trim-directory-separator
176          (make-pathname (take dir (sub1 (length dir))) (last dir))) )
177      (else
178        (sh:error-type 'make-directory-name dir) ) ) ) )
179
180;; System bundles are here:
181
182(define-constant DEFAULT-BUNDLE-DIR "srfi-29-bundles")
183
184;Within the bundle directory the structure
185;is [<language> [<country> [<details>...]]] (package-name).
186
187(define DEFAULT-SYSTEM-BUNDLES (make-home-pathname DEFAULT-BUNDLE-DIR))
188
189;; Filename Support
190
191(define (make-bundle-pathname #!optional spec)
192  (if (or (not spec) (null? spec))
193    (system-bundle-directory)
194    (make-directory-name (cons (system-bundle-directory) spec)) ) )
195
196;
197
198#; ;UNUSED
199(define (check-system-bundle-directory)
200  (unless (directory-exists? (system-bundle-directory))
201    (error "missing bundles directory; please install SRFI-29") ))
202
203;#; ;UNUSED
204(define (ensure-srfi-29-bundle-chmod spec #!optional (mod 'a+rx))
205  (when spec
206    (let loop ((dn (make-bundle-pathname)) (nms spec))
207      (unless (null? nms)
208        (let ((dn (make-directory-name (cons dn `(,(car nms))))))
209          #; ;No chmod "eager"
210          (file-chmod dn mod)
211          (loop dn (cdr nms)) ) ) ) ) )
212
213(define (create-bundle-directory spec)
214  (let (
215    (dir (make-bundle-pathname spec)) )
216    ;#; ;Permissions ?
217    (create-directory dir #t)
218    #; ;No chmod "eager"
219    (ensure-srfi-29-bundle-chmod spec)
220    ;
221    dir ) )
222
223;;;
224
225;; Where
226
227;(: system-bundle-directory (#!optional pathname -> (or void pathname)))
228(define-warning-parameter system-bundle-directory DEFAULT-SYSTEM-BUNDLES pathname)
229
230;; SRFI-29 Bundle Support
231
232(define (install-bundle nam . spec)
233  ;(check-system-bundle-directory)
234  (let* (
235    (nam (->locale-item nam))
236    (spec (map ->locale-item spec))
237    (dir (create-bundle-directory spec)) )
238    (let (
239      ;explicit curdir ('.') because problems in the past.
240      (from (make-pathname (cons "." spec) nam))
241      (to (make-pathname dir nam)) )
242      (copy-file from to #t)
243      #; ;No chmod "lazy"
244      (file-chmod to 'a+r) ) ) )
245
246) ;module srfi-29-install
Note: See TracBrowser for help on using the repository browser.