blob: c69d331044868492ec01cea8bf8f8669c1f72e4c (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
|
;; This file is part of Idest
;; Copyright (C) 2011 Sergey Poznyakoff
;;
;; Idest is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;;
;; Idest is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Idest. If not, see <http://www.gnu.org/licenses/>.
(define-module (idest list-modules))
(use-modules (ice-9 getopt-long)
(srfi srfi-1))
(define (strip-suffix name)
(call-with-current-continuation
(lambda (return)
(for-each
(lambda (suf)
(if (and (not (string-null? suf)) (string-suffix? suf name))
(return
(substring name 0 (- (string-length name) (string-length suf))))))
%load-extensions)
(return #f))))
(define-public (idest-list-modules type)
(let ((progname (car (command-line)))
(grammar `((which (single-char #\w))))
(print-dir #f))
(catch 'misc-error
(lambda ()
(for-each
(lambda (x)
(case (car x)
((which)
(set! print-dir #t))
(else
(set-program-arguments (cons progname (cdr x))))))
(getopt-long (command-line) grammar)))
(lambda (key . args)
(with-output-to-port
(current-error-port)
(lambda ()
(format #t "~A: " progname)
(apply format #t (list-ref args 1) (list-ref args 2))
(newline)
(exit 1)))))
(let ((saved-load-hook %load-hook)
;; Collect a list of possible modules. List elements are conses:
;; (basename . dir)
;; where basename is the module name and dir is the directory where
;; it is found. Make sure only one entry for each basename exists.
;; Sort the list alphabetically on basename.
(candidates
(sort
(fold
(lambda (elt prev)
(catch 'misc-error
(lambda ()
(let ((dir (string-append elt "/idest/"
(symbol->string type))))
(if (and dir
(file-exists? dir)
(eq? (stat:type (stat dir)) 'directory))
(let ((d (opendir dir)))
(let loop ((file (readdir d)))
(cond
((not (eof-object? file))
(if (eq? (stat:type
(stat
(string-append dir "/" file)))
'regular)
(let ((base (strip-suffix file)))
(if (and base
(not (assoc-ref prev base)))
(set! prev (cons (cons base dir)
prev)))))
(loop (readdir d)))))))))
(lambda (key . args)
#f))
prev)
'()
%load-path)
(lambda (a b)
(string<? (car a) (car b))))))
;; Try out each candidate and print ist name, directory and description
;; if it happens to be a valid idest format module.
;; Take care not to bail out on errors. Disable %load-hook as it migh
;; clobber the output.
(set! %load-hook #f)
(for-each
(lambda (candidate)
(catch 'misc-error
(lambda ()
(let ((mod (resolve-module
(list 'idest type
(string->symbol (car candidate))))))
; Check if it defines idest-main
(module-ref mod 'idest-main)
; Print module name
(display (car candidate))
; Its directory, if required
(if print-dir
(format #t " (~A)" (cdr candidate)))
; A colon, and description (if any
(format #t ": ~A~%"
(catch #t
(lambda ()
(module-ref mod 'description))
(lambda (key . args)
"no description")))))
(lambda (key . args)
#f)))
candidates)
(newline)
(set! %load-hook saved-load-hook))))
|