Skip to content

John McEleney / mailutils

Go to a project
Toggle navigation
Toggle navigation pinning
Commit 273e66dc 273e66dcf41df1fc262629b85b4cde983681d6c4 by Sergey Poznyakoff
Options

Reincarnate guimb as a pure Scheme program. 

* libmu_scm/mailutils.scm.in: Move to libmu_scm/mailutils/mailutils.scm.in.
Use the MAILUTILS_SCM_LIBRARY_ROOT environment variable to load
libraries from the specified location (to be used in tests).

* libmu_scm/mailutils/.gitignore: New file.
* libmu_scm/mailutils/Makefile.am: New file.
* libmu_scm/Makefile.am (SUBDIRS): Add mailutils
(mailutils.scm): Remove goal and associated variables.

* scheme/guimb.scmi: New file. Reincarnation of guimb.
* scheme/Makefile.am: Build guimb from guimb.scmi.
* scheme/sieve2scm.scmi (sieve-version): Use mu-package
and mu-version global variables.

* configure.ac (AC_CONFIG_FILES): Add libmu_scm/mailutils/Makefile.
1 parent 91022df9
Inline Side-by-side
Showing 8 changed files with 365 additions and 39 deletions
...@@ -1364,6 +1364,7 @@ AC_CONFIG_FILES([ ...@@ -1364,6 +1364,7 @@ AC_CONFIG_FILES([
1364 libmu_cfg/Makefile 1364 libmu_cfg/Makefile
1365 libmu_cpp/Makefile 1365 libmu_cpp/Makefile
1366 libmu_scm/Makefile 1366 libmu_scm/Makefile
1367 libmu_scm/mailutils/Makefile
1367 libmu_sieve/Makefile 1368 libmu_sieve/Makefile
1368 libmu_sieve/extensions/Makefile 1369 libmu_sieve/extensions/Makefile
1369 libproto/Makefile 1370 libproto/Makefile
......
...@@ -15,6 +15,8 @@ ...@@ -15,6 +15,8 @@
15 ## You should have received a copy of the GNU General Public License 15 ## You should have received a copy of the GNU General Public License
16 ## along with GNU Mailutils. If not, see <http://www.gnu.org/licenses/>. 16 ## along with GNU Mailutils. If not, see <http://www.gnu.org/licenses/>.
17 17
18 SUBDIRS = . mailutils
19
18 INCLUDES = -I. @MU_LIB_COMMON_INCLUDES@ @GUILE_INCLUDES@ 20 INCLUDES = -I. @MU_LIB_COMMON_INCLUDES@ @GUILE_INCLUDES@
19 21
20 lib_LTLIBRARIES=libmu_scm.la 22 lib_LTLIBRARIES=libmu_scm.la
...@@ -48,8 +50,6 @@ libmu_scm_la_LIBADD = \ ...@@ -48,8 +50,6 @@ libmu_scm_la_LIBADD = \
48 ${MU_LIB_MAILUTILS}\ 50 ${MU_LIB_MAILUTILS}\
49 @GUILE_LIBS@ 51 @GUILE_LIBS@
50 52
51 EXTRA_DIST=mailutils.scm mailutils.scm.in
52
53 DOT_X_FILES=\ 53 DOT_X_FILES=\
54 mu_address.x\ 54 mu_address.x\
55 mu_body.x\ 55 mu_body.x\
...@@ -72,15 +72,9 @@ DOT_DOC_FILES=\ ...@@ -72,15 +72,9 @@ DOT_DOC_FILES=\
72 mu_scm.doc\ 72 mu_scm.doc\
73 mu_util.doc 73 mu_util.doc
74 74
75 EXTRA_DIST=
75 CLEANFILES= 76 CLEANFILES=
76 DISTCLEANFILES=\ 77 DISTCLEANFILES=
77 mailutils.scm
78
79 mailutils.scm: mailutils.scm.in
80 $(AM_V_GEN)m4 -DVERSION=$(VERSION) -DLIBDIR=$(libdir) \
81 -DSITEDIR=$(sitedir) \
82 -DBUILDDIR=$(top_builddir)/libmu_scm \
83 $(srcdir)/mailutils.scm.in > $@
84 78
85 install-data-hook: 79 install-data-hook:
86 @here=`pwd`; \ 80 @here=`pwd`; \
...@@ -93,7 +87,7 @@ install-data-hook: ...@@ -93,7 +87,7 @@ install-data-hook:
93 cd $$here 87 cd $$here
94 88
95 sitedir = @GUILE_SITE@/$(PACKAGE) 89 sitedir = @GUILE_SITE@/$(PACKAGE)
96 site_DATA = mailutils.scm 90 site_DATA =
97 SUFFIXES= 91 SUFFIXES=
98 BUILT_SOURCES= 92 BUILT_SOURCES=
99 include ../gint/gint.mk 93 include ../gint/gint.mk
......
1 ## This file is part of GNU Mailutils.
2 ## Copyright (C) 2001, 2002, 2006, 2007, 2009, 2010, 2011 Free Software
3 ## Foundation, Inc.
4 ##
5 ## GNU Mailutils is free software; you can redistribute it and/or
6 ## modify it under the terms of the GNU General Public License as
7 ## published by the Free Software Foundation; either version 3, or (at
8 ## your option) any later version.
9 ##
10 ## GNU Mailutils is distributed in the hope that it will be useful, but
11 ## WITHOUT ANY WARRANTY; without even the implied warranty of
12 ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ## General Public License for more details.
14 ##
15 ## You should have received a copy of the GNU General Public License
16 ## along with GNU Mailutils. If not, see <http://www.gnu.org/licenses/>.
17
18 EXTRA_DIST=mailutils.scm mailutils.scm.in
19
20 DISTCLEANFILES=\
21 mailutils.scm
22
23 sitedir = @GUILE_SITE@/$(PACKAGE)
24 site_DATA = mailutils.scm
25
26 mailutils.scm: mailutils.scm.in
27 $(AM_V_GEN)m4 -DVERSION=$(VERSION) -DLIBDIR=$(libdir) \
28 -DSITEDIR=$(sitedir) \
29 -DBUILDDIR=$(top_builddir)/libmu_scm \
30 $(srcdir)/mailutils.scm.in > $@
31
...@@ -24,20 +24,31 @@ changequote([,])dnl ...@@ -24,20 +24,31 @@ changequote([,])dnl
24 (set! documentation-files (append documentation-files 24 (set! documentation-files (append documentation-files
25 (list "SITEDIR/guile-procedures.txt"))) 25 (list "SITEDIR/guile-procedures.txt")))
26 26
27 (define mu-libs (list "libmailutils" 27 (define mu-libs (list (cons "libmailutils" "libmailutils")
28 "libmu_auth" 28 (cons "libmu_auth" "libmu_auth")
29 "libmu_mbox" 29 (cons "libproto/mbox" "libmu_mbox")
30 "libmu_mh" 30 (cons "libproto/mh" "libmu_mh")
31 "libmu_maildir" 31 (cons "libproto/maildir" "libmu_maildir")
32 "libmu_pop" 32 (cons "libproto/pop" "libmu_pop")
33 "libmu_imap")) 33 (cons "libproto/imap" "libmu_imap")))
34 34
35 (let ((lib-path "LIBDIR/")) 35 (cond
36 (for-each 36 ((getenv "MAILUTILS_SCM_LIBRARY_ROOT") =>
37 (lambda (lib) 37 (lambda (root)
38 (dynamic-link (string-append lib-path lib))) 38 (for-each
39 mu-libs) 39 (lambda (lib)
40 (load-extension (string-append 40 (dynamic-link (string-append root "/" (car lib) "/" (cdr lib))))
41 lib-path "libguile-mailutils-v-VERSION") "mu_scm_init")) 41 mu-libs)
42 (load-extension (string-append root "/libmu_scm/libmu_scm")
43 "mu_scm_init")))
44 (else
45 (let ((lib-path "LIBDIR/"))
46 (for-each
47 (lambda (lib)
48 (dynamic-link (string-append lib-path (cdr lib))))
49 mu-libs)
50 (load-extension (string-append
51 lib-path "libguile-mailutils-v-VERSION")
52 "mu_scm_init"))))
42 53
43 ;;;; End of mailutils.scm 54 ;;;; End of mailutils.scm
......
...@@ -15,8 +15,8 @@ ...@@ -15,8 +15,8 @@
15 ## You should have received a copy of the GNU General Public License 15 ## You should have received a copy of the GNU General Public License
16 ## along with GNU Mailutils. If not, see <http://www.gnu.org/licenses/>. 16 ## along with GNU Mailutils. If not, see <http://www.gnu.org/licenses/>.
17 17
18 bin_SCRIPTS = sieve2scm 18 bin_SCRIPTS = sieve2scm guimb
19 EXTRA_SCRIPTS=sieve2scm 19
20 # FIXME: Sieve2scm is temporarly exempted from installchecks because 20 # FIXME: Sieve2scm is temporarly exempted from installchecks because
21 # it may fail starting during checks, if libguile-mailutils-v- library 21 # it may fail starting during checks, if libguile-mailutils-v- library
22 # has not been previously installed. The proper fix would be to alter 22 # has not been previously installed. The proper fix would be to alter
...@@ -25,19 +25,23 @@ AM_INSTALLCHECK_STD_OPTIONS_EXEMPT=sieve2scm ...@@ -25,19 +25,23 @@ AM_INSTALLCHECK_STD_OPTIONS_EXEMPT=sieve2scm
25 25
26 sievemoddir=@MU_GUILE_SIEVE_MOD_DIR@ 26 sievemoddir=@MU_GUILE_SIEVE_MOD_DIR@
27 27
28 sieve2scm: sieve2scm.scmi sieve.sed 28 sieve2scm: sieve2scm.scmi package.sed
29 $(AM_V_GEN)sed -f sieve.sed $(srcdir)/sieve2scm.scmi > sieve2scm 29 $(AM_V_GEN)sed -f package.sed $(srcdir)/sieve2scm.scmi > sieve2scm
30 $(AM_V_at)chmod +w sieve2scm 30 $(AM_V_at)chmod +w sieve2scm
31 31
32 sieve.sed: Makefile 32 guimb: guimb.scmi package.sed
33 $(AM_V_GEN)echo 's,%GUILE_BINDIR%,@GUILE_BINDIR@,g' > sieve.sed 33 $(AM_V_GEN)sed -f package.sed $(srcdir)/guimb.scmi > guimb
34 $(AM_V_at)echo 's,%BINDIR%,$(bindir),g' >> sieve.sed 34 $(AM_V_at)chmod +w guimb
35 $(AM_V_at)echo 's,%GUILE_SITE%,$(GUILE_SITE),g' >> sieve.sed 35
36 $(AM_V_at)echo 's,%LIBDIR%,$(sievemoddir),g' >> sieve.sed 36 package.sed: Makefile
37 $(AM_V_at)echo 's,%PACKAGE%,$(PACKAGE),g' >> sieve.sed 37 $(AM_V_GEN)echo 's,%GUILE_BINDIR%,@GUILE_BINDIR@,g' > package.sed
38 $(AM_V_at)echo 's,%VERSION%,$(VERSION),g' >> sieve.sed 38 $(AM_V_at)echo 's,%BINDIR%,$(bindir),g' >> package.sed
39 $(AM_V_at)echo 's,%GUILE_SITE%,$(GUILE_SITE),g' >> package.sed
40 $(AM_V_at)echo 's,%LIBDIR%,$(sievemoddir),g' >> package.sed
41 $(AM_V_at)echo 's,%PACKAGE%,$(PACKAGE),g' >> package.sed
42 $(AM_V_at)echo 's,%VERSION%,$(VERSION),g' >> package.sed
39 43
40 CLEANFILES = sieve2scm sieve.sed 44 CLEANFILES = sieve2scm guimb package.sed
41 45
42 sitedir=@GUILE_SITE@/$(PACKAGE) 46 sitedir=@GUILE_SITE@/$(PACKAGE)
43 site_DATA=sieve-core.scm 47 site_DATA=sieve-core.scm
......
1 #! /bin/sh
2 # aside from this initial boilerplate, this is actually -*- scheme -*- code
3 main='(module-ref (resolve-module '\''(scheme guimb)) '\'main')'
4 exec ${GUILE-guile} -l $0 -c "(apply $main (list (command-line)))" "$@"
5 !#
6 ;;;; GNU Mailutils -- a suite of utilities for electronic mail
7 ;;;; Copyright (C) 1999, 2000, 2001, 2006, 2007, 2009, 2010, 2011 Free
8 ;;;; Software Foundation, Inc.
9 ;;;;
10 ;;;; GNU Mailutils is free software; you can redistribute it and/or modify
11 ;;;; it under the terms of the GNU General Public License as published by
12 ;;;; the Free Software Foundation; either version 3, or (at your option)
13 ;;;; any later version.
14 ;;;;
15 ;;;; GNU Mailutils is distributed in the hope that it will be useful,
16 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;;;; GNU General Public License for more details.
19 ;;;;
20 ;;;; You should have received a copy of the GNU General Public License along
21 ;;;; with GNU Mailutils. If not, see <http://www.gnu.org/licenses/>.
22 ;;;;
23 (if (not (member "%GUILE_SITE%" %load-path))
24 (set! %load-path (cons "%GUILE_SITE%" %load-path)))
25 (define-module (scheme guimb)
26 :export (guimb))
27
28 (use-modules (ice-9 getopt-long)
29 (ice-9 rdelim)
30 (srfi srfi-1)
31 (mailutils mailutils))
32
33 (define program-name "guimb")
34 (define output-mailbox-name #f)
35 (define output-mailbox-mode #f)
36 (define source-file-name #f)
37 (define source-expression #f)
38 (define user-name #f)
39 (define input-mailbox-names '())
40 (define script-arguments '())
41
42 (define output-mailbox #f)
43
44 (define (guimb-version)
45 (format #t "guimb (~A) ~A~%" mu-package mu-version)
46 (exit 0))
47
48 (define (guimb-help)
49 (format #t "usage: guimb [OPTIONS] [MAILBOX [MAILBOX...]]
50 guimb applies a scheme function to each message from a set of input mailboxes
51
52 The following options stop argument processing, and pass all remaining
53 arguments as the value of (command-line):
54
55 -c, --code=EXPR execute given scheme expression
56 -s, --source=FILE load Scheme module from FILE.scm
57
58 The following options do not affect further options parsing:
59
60 -e, --expression=EXPR execute given scheme expression
61 -f, --file=FILE load Scheme module from FILE.scm
62
63 Other options:
64
65 -M, --mailbox=NAME set output mailbox name
66 -u, --user[=NAME] act as local MDA for user NAME (default - current
67 user)
68 -r, --read-only open mailbox in read-only mode
69
70 Script arguments:
71
72 -g, --guile-arg=ARG append ARG to the command line passed to script
73 -{ args... -} append args to the command line passed to script
74 --lparen args... --rparen likewise
75
76 -L, --load-path=PATH append PATH to the beginning of the %load-path
77
78 -?, --help give this help list
79 --usage give a short usage message
80 -V, --version print program version
81
82 Mandatory or optional arguments to long options are also mandatory or optional
83 for any corresponding short options.
84
85 ")
86 (format #t "Report bugs to <~A>.~%" mu-bugreport)
87 (exit 0))
88
89 (define (guimb-usage)
90 ; FIXME
91 (guimb-help))
92
93 (define (error fmt . rest)
94 (with-output-to-port
95 (current-error-port)
96 (lambda ()
97 (format #t "~A: " program-name)
98 (apply format #t fmt rest)
99 (newline))))
100
101 (define (extract-args arglist)
102 (let ((level 0))
103 (let ((result (filter
104 (lambda (x)
105 (cond
106 ((or (string=? x "--lparen")
107 (string=? x "-{"))
108 (set! level (+ level 1))
109 #f)
110 ((or (string=? x "--rparen")
111 (string=? x "-}"))
112 (if (> level 0)
113 (set! level (- level 1))
114 (set! script-arguments (append script-arguments
115 (list x))))
116 #f)
117 ((> level 0)
118 (set! script-arguments (append script-arguments
119 (list x)))
120 #f)
121 (else
122 #t)))
123 arglist)))
124 (if (> level 0)
125 (error "missing closing -}"))
126 result)))
127
128 (define (parse-cmdline cmdline)
129 (let ((grammar `((source (single-char #\s)
130 (value #t))
131 (code (single-char #\c)
132 (value #t))
133 (file (single-char #\f)
134 (value #t))
135 (expression (single-char #\e)
136 (value #t))
137 (mailbox (single-char #\M)
138 (value #t))
139 (user (single-char #\u)
140 (value optional))
141 (read-only (single-char #\r))
142 (guile-arg (single-char #\g)
143 (value #t))
144 (load-path (single-char #\L)
145 (value #t))
146 (help (single-char #\?))
147 (usage)
148 (version (single-char #\V)))))
149 (do ((arglist (getopt-long (extract-args (command-line)) grammar)
150 (cdr arglist)))
151 ((null? arglist))
152 (let ((x (car arglist)))
153 (case (car x)
154 ((mailbox)
155 (set! output-mailbox-name (cdr x)))
156 ((source file)
157 (set! source-file-name (cdr x)))
158 ((code expression)
159 (set! source-expression (cdr x)))
160 ((load-path)
161 (set! %load-path (append
162 (string-split (cdr x) #\:)
163 %load-path)))
164 ((user)
165 (set! user-name (cdr x)))
166 ((guile-arg)
167 (set! script-arguments (append script-arguments (list (cdr x)))))
168 ((version)
169 (guimb-version))
170 ((help)
171 (guimb-help))
172 ((usage)
173 (guimb-usage))
174 ((read-only)
175 (set! output-mailbox-mode "r"))
176 ('()
177 (if (not (null? (cdr x)))
178 (set! input-mailbox-names (append input-mailbox-names
179 (cdr x))))))))))
180
181 (define guimb-module #f)
182
183 (define (get-module)
184 (if (not guimb-module)
185 (set! guimb-module (resolve-module '(scheme guimb))))
186 guimb-module)
187
188 (define-macro (bound? name)
189 `(and (module-defined? guimb-module ',name)
190 (procedure? ,name)))
191
192 (define (guimb-parse-command-line cmdline)
193 (let ((script-args '())
194 (argtail (find-tail
195 (lambda (x)
196 (or (string=? x "-c")
197 (string=? x "--code")
198 (string=? x "-s")
199 (string=? x "--source")
200 (string-prefix? "--code=" x)
201 (string-prefix? "--source=" x)))
202 cmdline)))
203 (cond
204 (argtail
205 (if (let ((x (car argtail)))
206 (not (or (string-prefix? "--code=" x)
207 (string-prefix? "--source=" x))))
208 (set! argtail (cdr argtail)))
209 (cond ((not (null? argtail))
210 (set! script-args (cdr argtail))
211 (set-cdr! argtail '())))))
212 (parse-cmdline cmdline)
213 (set! script-arguments (append script-arguments script-args))
214
215 (if (not output-mailbox-mode)
216 (set! output-mailbox-mode (if (null? input-mailbox-names) "wr" "a")))
217
218 (cond
219 (user-name
220 (set! output-mailbox
221 (mu-mailbox-open
222 (if (string? user-name)
223 (string-append "%" user-name)
224 "")
225 output-mailbox-mode)))
226 (output-mailbox-name
227 (set! output-mailbox (mu-mailbox-open output-mailbox-name
228 output-mailbox-mode))))
229 ; (write output-mailbox)(newline)
230
231 (if source-file-name
232 (module-use!
233 (get-module)
234 (resolve-interface (list (string->symbol source-file-name)))))
235 (if source-expression
236 (eval-string source-expression))
237
238 (if (bound? guimb-getopt)
239 (guimb-getopt script-arguments)) ))
240
241 (define (guimb-single-mailbox mbox)
242 (let msg-loop ((msg (mu-mailbox-first-message mbox)))
243 (if (not (eof-object? msg))
244 (begin
245 (guimb-message msg)
246 (msg-loop (mu-mailbox-next-message mbox))))))
247
248 (define (guimb-process-mailbox mbox)
249 (if (not output-mailbox)
250 (guimb-single-mailbox mbox)
251 (let msg-loop ((msg (mu-mailbox-first-message mbox)))
252 (if (not (eof-object? msg))
253 (begin
254 (if (guimb-message msg)
255 (mu-mailbox-append-message output-mailbox msg))
256 (msg-loop (mu-mailbox-next-message mbox)))))))
257
258 (define (guimb cmdline)
259 (mu-register-format)
260 (guimb-parse-command-line cmdline)
261 (if (null? input-mailbox-names)
262 (guimb-single-mailbox output-mailbox)
263 (for-each
264 (lambda (mbox-name)
265 (let ((current-mailbox (mu-mailbox-open mbox-name "r")))
266 (guimb-process-mailbox current-mailbox)))
267 input-mailbox-names))
268 (if (bound? guimb-end)
269 (guimb-end)))
270
271 (debug-enable 'debug)
272 (debug-options '(show-file-name #t
273 stack 20000
274 debug
275 backtrace
276 depth 20
277 maxdepth 1000
278 frames 3
279 indent 10
280 width 79
281 procnames))
282
283 (define main guimb)
284
285 ;;;; End of guimb
...@@ -995,8 +995,7 @@ exec ${GUILE-guile} -l $0 -c '(mailutils-main)'\n") ...@@ -995,8 +995,7 @@ exec ${GUILE-guile} -l $0 -c '(mailutils-main)'\n")
995 (exit 0)) 995 (exit 0))
996 996
997 (define (sieve-version) 997 (define (sieve-version)
998 (display "sieve2scm (GNU %PACKAGE% %VERSION%)") 998 (format #t "sieve2scm (~A) ~A~%" mu-package mu-version)
999 (newline)
1000 (exit 0)) 999 (exit 0))
1001 1000
1002 ;;; Parse command line 1001 ;;; Parse command line
......