/tools/error-code-snarf.scm
Scheme | 345 lines | 250 code | 26 blank | 69 comment | 0 complexity | b207a6f57cd787205985cbc8ea928f0e MD5 | raw file
- #!/bin/sh
- exec guile -e main -s "$0" "$@"
- !#
- ;;; GPGME/G : GPGME with Guile
- ;;;
- ;;; A Guile binding to the GPGME library
- ;;; Error setup tools
- ;;;
- ;;; Copyright © 2011, 2013 Atom X Zane
- ;;;
- ;;; This library 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 of the
- ;;; License, or (at your option) any later version.
- ;;;
- ;;; This library is distributed in the hope that it will be useful,
- ;;; but WITHOUT ANY WARRANTY; without even the implide 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 this library. If not, see
- ;;; <http://www.gnu.org/licenses/>.
- ;;; Commentary:
- ;; The GPGME library deals with a @emph{lot} of error cases, some of
- ;; which are moving targets as far as creating bindings are concerned.
- ;; The procedures in this file are a simple set of tools that allow at
- ;; least some automation of the error binding process.
- ;;
- ;; The libgpg-error distribution includes several files where errors
- ;; and error sources are defined:
- ;;
- ;; @table @samp
- ;; @item err-codes.h.in
- ;; The GPG-specifice error codes and descriptions. The format is,
- ;; line-by-line,
- ;; @code{^[[:digits:]]+[\t]+[A-Z][A-Z_]+[A-Z][\t]+[[:alnum:] ]+$}
- ;;
- ;; @item err-sources.h.in
- ;; GPG error sources and descriptions. The format is the same as
- ;; for @samp{err-codes.h.in}
- ;;
- ;; @item errnos.in
- ;; The system-error translation table. The format is,
- ;; line-by-line:
- ;; @code{^[[:digit:]]+[\t]+[A-Z]+$}
- ;;
- ;; A special value, which shows up as
- ;; @code{#define GPG_ERR_SYSTEM_ERROR (1 << 15)}
- ;; in the resulting @samp{gpg-error.h} file is used as the basis
- ;; for the system error translation: the leading number of the
- ;; errors declared in @samp{errnos.in} are bitwise-or'ed with
- ;; @code{GPG_ERR_SYSTEM_ERROR} to get their final number. We will
- ;; put their actual values in to save on computation time.
- ;;
- ;; @end table
- ;;
- ;; At this time these tools are for GPGME/Guile developers' use only;
- ;; they require the libgpg-error sources to work properly, which users
- ;; cannot be expected to have on hand. As such, the files
- ;; @samp{error-sources.scm} and @samp{error-codes.scm} are to be
- ;; distributed complete with each release, or possibly even in the
- ;; archives themselves. *** FIXME ***
- ;;; Code:
- (use-modules (ice-9 popen)
- (ice-9 rdelim)
- (ice-9 regex)
- (ice-9 pretty-print)
- (ice-9 binary-ports)
- (rnrs bytevectors)
- (srfi srfi-1)
- (system foreign))
- (define libgpg-error (dynamic-link "libgpg-error"))
- (define *libgpg-error-prefix*
- (let* ((p (open-input-pipe "gpg-error-config --cflags"))
- (dir (substring (read-line p) 2)))
- (close-pipe p)
- dir))
- (define error-code->description
- (let ((gpg-strerror
- (pointer->procedure
- '*
- (dynamic-func "gpg_strerror" libgpg-error)
- (list unsigned-int))))
- (lambda (code)
- (pointer->string
- (gpg-strerror code)))))
- (define error-source->description
- (let ((gpg-strsource
- (pointer->procedure
- '*
- (dynamic-func "gpg_strsource" libgpg-error)
- (list unsigned-int)))
- (source-mask 127)
- (source-shift (1- (expt 2 7))))
- (lambda (code)
- (pointer->string
- (gpg-strsource (ash (logand code source-mask) 24))))))
- (define (error-code->number code)
- (let ((mask (ash 1 15))
- (num
- (string->number
- (string-delete (char-set-complement char-set:digit) code))))
- (if (string-prefix? "GPG_ERR_SYSTEM_ERROR" code)
- (logior mask num)
- num)))
- (define (error-string->pair str)
- (let ((err-pair
- (map
- (lambda (s)
- (string-trim-both
- s (char-set #\space #\,)))
- (string-split str #\=))))
- (cons
- (car err-pair)
- (error-code->number (cadr err-pair)))))
- (define (c-error-name->symbol cname)
- (define prefix-rx (make-regexp "(GPG_ERR(_SOURCE)?)[_-]"))
- (let ((prefix
- (or (and (string-prefix? "GPG_ERR_SOURCE_" cname)
- "error-source")
- (and (string-prefix? "GPG_ERR_" cname)
- "error-code")
- (error "Unknown error symbol" cname)))
- (name (string-join
- (string-split
- (string-downcase
- (match:suffix
- (regexp-exec prefix-rx cname)))
- #\_)
- "-")))
- (string->symbol
- (string-append prefix "/" name))))
- (define (extract-error-sources error-list)
- (map error-string->pair
- (filter (lambda (str)
- (and (string-prefix? "GPG_ERR_SOURCE" str)
- (string-index str #\=)))
- error-list)))
- (define (extract-error-codes error-list)
- (map error-string->pair
- (filter (lambda (str)
- (and (string-prefix? "GPG_ERR" str)
- (not (string-prefix? "GPG_ERR_SOURCE" str))
- (string-index str #\=)))
- error-list)))
- (define (output-error-code-define error-pair)
- (let ((name (c-error-name->symbol (car error-pair)))
- (value (cdr error-pair))
- (description (error-code->description
- (cdr error-pair))))
- `(define-public ,name (make-error-code ,value ,description))))
- (define (output-error-source-define error-pair)
- (let ((name (c-error-name->symbol (car error-pair)))
- (value (cdr error-pair))
- (description (error-source->description
- (cdr error-pair))))
- `(define-public ,name (make-error-source ,value ,description))))
- (define (extract-error-decls lines)
- (map
- (lambda (line)
- (string-trim-both line (char-set-adjoin char-set:whitespace #\,)))
- (filter (lambda (line)
- (string-match "^[[:space:]]*GPG_ERR_.*[[:digit:]],?" line))
- lines)))
- (define (output-error-code-dim input dim-value)
- (regexp-substitute
- #f (string-match "@@ERROR_CODE_DIM@@" input)
- 'pre dim-value 'post))
- (define (output-error-code-decls input decls)
- (regexp-substitute
- #f (string-match "@@ERROR_CODE_DECLS@@" input)
- 'pre decls 'post))
- (define (output-error-code-lookup input lookups)
- (let ((l (string-append
- " `"
- (substring
- (regexp-substitute/global
- #f
- "(error-code/)"
- (with-output-to-string
- (lambda ()
- (pretty-print
- (let loop ((rest lookups)
- (done '()))
- (if (null? rest)
- (reverse done)
- (loop (cdr rest)
- (if (string= (caar rest) "GPG_ERR_CODE_DIM")
- done
- (cons
- (cons (cdar rest)
- (c-error-name->symbol (caar rest)))
- done)))))
- #:per-line-prefix " ")))
- 'pre "," 1 'post)
- 4))))
- (regexp-substitute
- #f (string-match "@@ERROR_CODE_LOOKUP@@" input)
- 'pre l 'post)))
- (define (output-error-source-dim input dim-value)
- (regexp-substitute
- #f (string-match "@@ERROR_SOURCE_DIM@@" input)
- 'pre dim-value 'post))
- (define (output-error-source-decls input decls)
- (regexp-substitute
- #f (string-match "@@ERROR_SOURCE_DECLS@@" input)
- 'pre decls 'post))
- (define (output-error-source-lookup input lookups)
- (let ((l (string-append
- " `"
- (substring
- (regexp-substitute/global
- #f
- "(error-source/)"
- (with-output-to-string
- (lambda ()
- (pretty-print
- (let loop ((rest lookups)
- (done '()))
- (if (null? rest)
- (reverse done)
- (loop (cdr rest)
- (if (string= (caar rest) "GPG_ERR_SOURCE_DIM")
- done
- (cons
- (cons (cdar rest)
- (c-error-name->symbol (caar rest)))
- done)))))
- #:per-line-prefix " ")))
- 'pre "," 1 'post)
- 4))))
- (regexp-substitute
- #f (string-match "@@ERROR_SOURCE_LOOKUP@@" input)
- 'pre l 'post)))
- (define (main . args)
- (let* ((error-decls
- (extract-error-decls
- (let ((p (open-input-file (string-append
- *libgpg-error-prefix*
- "/gpg-error.h"))))
- (let loop ((line (read-line p))
- (lines '()))
- (if (eof-object? line)
- (begin
- (close-port p)
- (reverse lines))
- (loop (read-line p)
- (cons line lines)))))))
- ;; error codes
- (error-codes (extract-error-codes error-decls))
- (error-code-defines
- (with-output-to-string
- (lambda ()
- (for-each
- (lambda (defn)
- (if (not (string=
- (car defn)
- "GPG_ERR_CODE_DIM"))
- (pretty-print (output-error-code-define defn))
- (display "")))
- error-codes))))
- ;; error sources
- (error-sources (extract-error-sources error-decls))
- (error-source-defines
- (with-output-to-string
- (lambda ()
- (for-each
- (lambda (defn)
- (if (not (string=
- (car defn)
- "GPG_ERR_SOURCE_DIM"))
- (pretty-print (output-error-source-define defn))
- (display "")))
- error-sources))))
- ;; input files
- (error-codes.scm.in
- (let* ((p (open-input-file
- "../src/gpg/error-codes.scm.in" #:binary #t))
- (bv (get-bytevector-all p)))
- (close-port p)
- (utf8->string bv)))
- (error-sources.scm.in
- (let* ((p (open-input-file
- "../src/gpg/error-sources.scm.in" #:binary #t))
- (bv (get-bytevector-all p)))
- (close-port p)
- (utf8->string bv)))
- ;; output-files
- (error-codes.scm
- (open-output-file "../src/gpg/error-codes.scm" #:binary #t))
- (error-sources.scm
- (open-output-file "../src/gpg/error-sources.scm" #:binary #t)))
- (put-bytevector
- error-codes.scm
- (string->utf8
- (output-error-code-lookup
- (output-error-code-decls
- (output-error-code-dim
- error-codes.scm.in
- (number->string (assoc-ref error-codes "GPG_ERR_CODE_DIM")))
- error-code-defines)
- error-codes)))
- (close-port error-codes.scm)
- (put-bytevector
- error-sources.scm
- (string->utf8
- (output-error-source-lookup
- (output-error-source-decls
- (output-error-source-dim
- error-sources.scm.in
- (number->string (assoc-ref error-sources "GPG_ERR_SOURCE_DIM")))
- error-source-defines)
- error-sources)))
- (close-port error-sources.scm)))
- ;; Local Variables:
- ;; mode: scheme
- ;; End:
- ;;; err-setup.scm ends here