diff options
author | Sergey Poznyakoff <gray@gnu.org.ua> | 2011-01-07 14:43:04 +0200 |
---|---|---|
committer | Sergey Poznyakoff <gray@gnu.org.ua> | 2011-01-07 14:43:04 +0200 |
commit | 273e66dcf41df1fc262629b85b4cde983681d6c4 (patch) | |
tree | 57f092b1fa10d4298a2da98c03d4e46140477431 /scheme | |
parent | 91022df9ce5b2ffafaf1b602f028922dc77e35e4 (diff) | |
download | mailutils-273e66dcf41df1fc262629b85b4cde983681d6c4.tar.gz mailutils-273e66dcf41df1fc262629b85b4cde983681d6c4.tar.bz2 |
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.
Diffstat (limited to 'scheme')
-rw-r--r-- | scheme/Makefile.am | 28 | ||||
-rw-r--r-- | scheme/guimb.scmi | 285 | ||||
-rw-r--r-- | scheme/sieve2scm.scmi | 3 |
3 files changed, 302 insertions, 14 deletions
diff --git a/scheme/Makefile.am b/scheme/Makefile.am index c0e0023a3..c146dfb96 100644 --- a/scheme/Makefile.am +++ b/scheme/Makefile.am @@ -15,8 +15,8 @@ ## You should have received a copy of the GNU General Public License ## along with GNU Mailutils. If not, see <http://www.gnu.org/licenses/>. -bin_SCRIPTS = sieve2scm -EXTRA_SCRIPTS=sieve2scm +bin_SCRIPTS = sieve2scm guimb + # FIXME: Sieve2scm is temporarly exempted from installchecks because # it may fail starting during checks, if libguile-mailutils-v- library # has not been previously installed. The proper fix would be to alter @@ -25,19 +25,23 @@ AM_INSTALLCHECK_STD_OPTIONS_EXEMPT=sieve2scm sievemoddir=@MU_GUILE_SIEVE_MOD_DIR@ -sieve2scm: sieve2scm.scmi sieve.sed - $(AM_V_GEN)sed -f sieve.sed $(srcdir)/sieve2scm.scmi > sieve2scm +sieve2scm: sieve2scm.scmi package.sed + $(AM_V_GEN)sed -f package.sed $(srcdir)/sieve2scm.scmi > sieve2scm $(AM_V_at)chmod +w sieve2scm -sieve.sed: Makefile - $(AM_V_GEN)echo 's,%GUILE_BINDIR%,@GUILE_BINDIR@,g' > sieve.sed - $(AM_V_at)echo 's,%BINDIR%,$(bindir),g' >> sieve.sed - $(AM_V_at)echo 's,%GUILE_SITE%,$(GUILE_SITE),g' >> sieve.sed - $(AM_V_at)echo 's,%LIBDIR%,$(sievemoddir),g' >> sieve.sed - $(AM_V_at)echo 's,%PACKAGE%,$(PACKAGE),g' >> sieve.sed - $(AM_V_at)echo 's,%VERSION%,$(VERSION),g' >> sieve.sed +guimb: guimb.scmi package.sed + $(AM_V_GEN)sed -f package.sed $(srcdir)/guimb.scmi > guimb + $(AM_V_at)chmod +w guimb + +package.sed: Makefile + $(AM_V_GEN)echo 's,%GUILE_BINDIR%,@GUILE_BINDIR@,g' > package.sed + $(AM_V_at)echo 's,%BINDIR%,$(bindir),g' >> package.sed + $(AM_V_at)echo 's,%GUILE_SITE%,$(GUILE_SITE),g' >> package.sed + $(AM_V_at)echo 's,%LIBDIR%,$(sievemoddir),g' >> package.sed + $(AM_V_at)echo 's,%PACKAGE%,$(PACKAGE),g' >> package.sed + $(AM_V_at)echo 's,%VERSION%,$(VERSION),g' >> package.sed -CLEANFILES = sieve2scm sieve.sed +CLEANFILES = sieve2scm guimb package.sed sitedir=@GUILE_SITE@/$(PACKAGE) site_DATA=sieve-core.scm diff --git a/scheme/guimb.scmi b/scheme/guimb.scmi new file mode 100644 index 000000000..f9540432a --- /dev/null +++ b/scheme/guimb.scmi @@ -0,0 +1,285 @@ +#! /bin/sh +# aside from this initial boilerplate, this is actually -*- scheme -*- code +main='(module-ref (resolve-module '\''(scheme guimb)) '\'main')' +exec ${GUILE-guile} -l $0 -c "(apply $main (list (command-line)))" "$@" +!# +;;;; GNU Mailutils -- a suite of utilities for electronic mail +;;;; Copyright (C) 1999, 2000, 2001, 2006, 2007, 2009, 2010, 2011 Free +;;;; Software Foundation, Inc. +;;;; +;;;; GNU Mailutils 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. +;;;; +;;;; GNU Mailutils 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 GNU Mailutils. If not, see <http://www.gnu.org/licenses/>. +;;;; +(if (not (member "%GUILE_SITE%" %load-path)) + (set! %load-path (cons "%GUILE_SITE%" %load-path))) +(define-module (scheme guimb) + :export (guimb)) + +(use-modules (ice-9 getopt-long) + (ice-9 rdelim) + (srfi srfi-1) + (mailutils mailutils)) + +(define program-name "guimb") +(define output-mailbox-name #f) +(define output-mailbox-mode #f) +(define source-file-name #f) +(define source-expression #f) +(define user-name #f) +(define input-mailbox-names '()) +(define script-arguments '()) + +(define output-mailbox #f) + +(define (guimb-version) + (format #t "guimb (~A) ~A~%" mu-package mu-version) + (exit 0)) + +(define (guimb-help) + (format #t "usage: guimb [OPTIONS] [MAILBOX [MAILBOX...]] +guimb applies a scheme function to each message from a set of input mailboxes + +The following options stop argument processing, and pass all remaining +arguments as the value of (command-line): + + -c, --code=EXPR execute given scheme expression + -s, --source=FILE load Scheme module from FILE.scm + +The following options do not affect further options parsing: + + -e, --expression=EXPR execute given scheme expression + -f, --file=FILE load Scheme module from FILE.scm + +Other options: + + -M, --mailbox=NAME set output mailbox name + -u, --user[=NAME] act as local MDA for user NAME (default - current + user) + -r, --read-only open mailbox in read-only mode + +Script arguments: + + -g, --guile-arg=ARG append ARG to the command line passed to script + -{ args... -} append args to the command line passed to script + --lparen args... --rparen likewise + + -L, --load-path=PATH append PATH to the beginning of the %load-path + + -?, --help give this help list + --usage give a short usage message + -V, --version print program version + +Mandatory or optional arguments to long options are also mandatory or optional +for any corresponding short options. + +") + (format #t "Report bugs to <~A>.~%" mu-bugreport) + (exit 0)) + +(define (guimb-usage) + ; FIXME + (guimb-help)) + +(define (error fmt . rest) + (with-output-to-port + (current-error-port) + (lambda () + (format #t "~A: " program-name) + (apply format #t fmt rest) + (newline)))) + +(define (extract-args arglist) + (let ((level 0)) + (let ((result (filter + (lambda (x) + (cond + ((or (string=? x "--lparen") + (string=? x "-{")) + (set! level (+ level 1)) + #f) + ((or (string=? x "--rparen") + (string=? x "-}")) + (if (> level 0) + (set! level (- level 1)) + (set! script-arguments (append script-arguments + (list x)))) + #f) + ((> level 0) + (set! script-arguments (append script-arguments + (list x))) + #f) + (else + #t))) + arglist))) + (if (> level 0) + (error "missing closing -}")) + result))) + +(define (parse-cmdline cmdline) + (let ((grammar `((source (single-char #\s) + (value #t)) + (code (single-char #\c) + (value #t)) + (file (single-char #\f) + (value #t)) + (expression (single-char #\e) + (value #t)) + (mailbox (single-char #\M) + (value #t)) + (user (single-char #\u) + (value optional)) + (read-only (single-char #\r)) + (guile-arg (single-char #\g) + (value #t)) + (load-path (single-char #\L) + (value #t)) + (help (single-char #\?)) + (usage) + (version (single-char #\V))))) + (do ((arglist (getopt-long (extract-args (command-line)) grammar) + (cdr arglist))) + ((null? arglist)) + (let ((x (car arglist))) + (case (car x) + ((mailbox) + (set! output-mailbox-name (cdr x))) + ((source file) + (set! source-file-name (cdr x))) + ((code expression) + (set! source-expression (cdr x))) + ((load-path) + (set! %load-path (append + (string-split (cdr x) #\:) + %load-path))) + ((user) + (set! user-name (cdr x))) + ((guile-arg) + (set! script-arguments (append script-arguments (list (cdr x))))) + ((version) + (guimb-version)) + ((help) + (guimb-help)) + ((usage) + (guimb-usage)) + ((read-only) + (set! output-mailbox-mode "r")) + ('() + (if (not (null? (cdr x))) + (set! input-mailbox-names (append input-mailbox-names + (cdr x)))))))))) + +(define guimb-module #f) + +(define (get-module) + (if (not guimb-module) + (set! guimb-module (resolve-module '(scheme guimb)))) + guimb-module) + +(define-macro (bound? name) + `(and (module-defined? guimb-module ',name) + (procedure? ,name))) + +(define (guimb-parse-command-line cmdline) + (let ((script-args '()) + (argtail (find-tail + (lambda (x) + (or (string=? x "-c") + (string=? x "--code") + (string=? x "-s") + (string=? x "--source") + (string-prefix? "--code=" x) + (string-prefix? "--source=" x))) + cmdline))) + (cond + (argtail + (if (let ((x (car argtail))) + (not (or (string-prefix? "--code=" x) + (string-prefix? "--source=" x)))) + (set! argtail (cdr argtail))) + (cond ((not (null? argtail)) + (set! script-args (cdr argtail)) + (set-cdr! argtail '()))))) + (parse-cmdline cmdline) + (set! script-arguments (append script-arguments script-args)) + + (if (not output-mailbox-mode) + (set! output-mailbox-mode (if (null? input-mailbox-names) "wr" "a"))) + + (cond + (user-name + (set! output-mailbox + (mu-mailbox-open + (if (string? user-name) + (string-append "%" user-name) + "") + output-mailbox-mode))) + (output-mailbox-name + (set! output-mailbox (mu-mailbox-open output-mailbox-name + output-mailbox-mode)))) +; (write output-mailbox)(newline) + + (if source-file-name + (module-use! + (get-module) + (resolve-interface (list (string->symbol source-file-name))))) + (if source-expression + (eval-string source-expression)) + + (if (bound? guimb-getopt) + (guimb-getopt script-arguments)) )) + +(define (guimb-single-mailbox mbox) + (let msg-loop ((msg (mu-mailbox-first-message mbox))) + (if (not (eof-object? msg)) + (begin + (guimb-message msg) + (msg-loop (mu-mailbox-next-message mbox)))))) + +(define (guimb-process-mailbox mbox) + (if (not output-mailbox) + (guimb-single-mailbox mbox) + (let msg-loop ((msg (mu-mailbox-first-message mbox))) + (if (not (eof-object? msg)) + (begin + (if (guimb-message msg) + (mu-mailbox-append-message output-mailbox msg)) + (msg-loop (mu-mailbox-next-message mbox))))))) + +(define (guimb cmdline) + (mu-register-format) + (guimb-parse-command-line cmdline) + (if (null? input-mailbox-names) + (guimb-single-mailbox output-mailbox) + (for-each + (lambda (mbox-name) + (let ((current-mailbox (mu-mailbox-open mbox-name "r"))) + (guimb-process-mailbox current-mailbox))) + input-mailbox-names)) + (if (bound? guimb-end) + (guimb-end))) + +(debug-enable 'debug) +(debug-options '(show-file-name #t + stack 20000 + debug + backtrace + depth 20 + maxdepth 1000 + frames 3 + indent 10 + width 79 + procnames)) + +(define main guimb) + +;;;; End of guimb diff --git a/scheme/sieve2scm.scmi b/scheme/sieve2scm.scmi index 6ab1ace5a..6d2c85d0b 100644 --- a/scheme/sieve2scm.scmi +++ b/scheme/sieve2scm.scmi @@ -995,8 +995,7 @@ exec ${GUILE-guile} -l $0 -c '(mailutils-main)'\n") (exit 0)) (define (sieve-version) - (display "sieve2scm (GNU %PACKAGE% %VERSION%)") - (newline) + (format #t "sieve2scm (~A) ~A~%" mu-package mu-version) (exit 0)) ;;; Parse command line |