PageRenderTime 65ms CodeModel.GetById 10ms app.highlight 44ms RepoModel.GetById 1ms app.codeStats 1ms

/tools/error-code-snarf.scm

http://github.com/xatom/GPGME-Guile
Scheme | 345 lines | 250 code | 26 blank | 69 comment | 0 complexity | b207a6f57cd787205985cbc8ea928f0e MD5 | raw file
  1#!/bin/sh
  2
  3exec guile -e main -s "$0" "$@"
  4!#
  5
  6;;; GPGME/G : GPGME with Guile
  7;;; 
  8;;; A Guile binding to the GPGME library
  9;;; Error setup tools
 10;;;
 11;;; Copyright © 2011, 2013 Atom X Zane
 12;;;
 13;;; This library is free software: you can redistribute it and/or
 14;;; modify it under the terms of the GNU General Public License as
 15;;; published by the Free Software Foundation, either version 3 of the
 16;;; License, or (at your option) any later version.
 17;;;
 18;;; This library is distributed in the hope that it will be useful,
 19;;; but WITHOUT ANY WARRANTY; without even the implide warranty of
 20;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 21;;; General Public License for more details.
 22;;;
 23;;; You should have received a copy of the GNU General Public License
 24;;; along with this library.  If not, see
 25;;; <http://www.gnu.org/licenses/>.
 26
 27;;; Commentary:
 28
 29;; The GPGME library deals with a @emph{lot} of error cases, some of
 30;; which are moving targets as far as creating bindings are concerned.
 31;; The procedures in this file are a simple set of tools that allow at
 32;; least some automation of the error binding process.
 33;;
 34;; The libgpg-error distribution includes several files where errors
 35;; and error sources are defined:
 36;; 
 37;; @table @samp
 38;; @item err-codes.h.in
 39;;    The GPG-specifice error codes and descriptions.  The format is,
 40;;    line-by-line,
 41;;       @code{^[[:digits:]]+[\t]+[A-Z][A-Z_]+[A-Z][\t]+[[:alnum:] ]+$}
 42;;   
 43;; @item err-sources.h.in
 44;;    GPG error sources and descriptions.  The format is the same as
 45;;    for @samp{err-codes.h.in}
 46;;
 47;; @item errnos.in
 48;;    The system-error translation table. The format is,
 49;;    line-by-line:
 50;;       @code{^[[:digit:]]+[\t]+[A-Z]+$}
 51;;      
 52;;    A special value, which shows up as
 53;;       @code{#define GPG_ERR_SYSTEM_ERROR (1 << 15)}
 54;;    in the resulting @samp{gpg-error.h} file is used as the basis
 55;;    for the system error translation: the leading number of the
 56;;    errors declared in @samp{errnos.in} are bitwise-or'ed with
 57;;    @code{GPG_ERR_SYSTEM_ERROR} to get their final number.  We will
 58;;    put their actual values in to save on computation time.
 59;;
 60;; @end table   
 61;;
 62;; At this time these tools are for GPGME/Guile developers' use only;
 63;; they require the libgpg-error sources to work properly, which users
 64;; cannot be expected to have on hand.  As such, the files
 65;; @samp{error-sources.scm} and @samp{error-codes.scm} are to be
 66;; distributed complete with each release, or possibly even in the
 67;; archives themselves.  *** FIXME ***
 68
 69;;; Code:
 70
 71(use-modules (ice-9 popen)
 72	     (ice-9 rdelim)
 73	     (ice-9 regex)
 74	     (ice-9 pretty-print)
 75             (ice-9 binary-ports)
 76             (rnrs bytevectors)
 77	     (srfi srfi-1)
 78             (system foreign))
 79
 80(define libgpg-error (dynamic-link "libgpg-error"))
 81
 82(define *libgpg-error-prefix*
 83  (let* ((p (open-input-pipe "gpg-error-config --cflags"))
 84         (dir (substring (read-line p) 2)))
 85    (close-pipe p)
 86    dir))
 87
 88(define error-code->description
 89  (let ((gpg-strerror
 90         (pointer->procedure
 91          '*
 92          (dynamic-func "gpg_strerror" libgpg-error)
 93          (list unsigned-int))))
 94    (lambda (code)
 95      (pointer->string
 96       (gpg-strerror code)))))
 97
 98(define error-source->description
 99  (let ((gpg-strsource
100         (pointer->procedure
101          '*
102          (dynamic-func "gpg_strsource" libgpg-error)
103          (list unsigned-int)))
104        (source-mask 127)
105        (source-shift (1- (expt 2 7))))
106    (lambda (code)
107      (pointer->string
108       (gpg-strsource (ash (logand code source-mask) 24))))))
109
110(define (error-code->number code)
111  (let ((mask (ash 1 15))
112        (num
113         (string->number
114          (string-delete (char-set-complement char-set:digit) code))))
115    (if (string-prefix? "GPG_ERR_SYSTEM_ERROR" code)
116        (logior mask num)
117        num)))
118
119(define (error-string->pair str)
120  (let ((err-pair
121         (map
122          (lambda (s)
123            (string-trim-both
124             s (char-set #\space #\,)))
125          (string-split str #\=))))
126    (cons
127     (car err-pair)
128     (error-code->number (cadr err-pair)))))
129
130(define (c-error-name->symbol cname)
131  (define prefix-rx (make-regexp "(GPG_ERR(_SOURCE)?)[_-]"))
132  (let ((prefix
133         (or (and (string-prefix? "GPG_ERR_SOURCE_" cname)
134                  "error-source")
135             (and (string-prefix? "GPG_ERR_" cname)
136                  "error-code")
137             (error "Unknown error symbol" cname)))
138        (name (string-join
139               (string-split
140                (string-downcase
141                 (match:suffix
142                  (regexp-exec prefix-rx cname)))
143                #\_)
144               "-")))
145    (string->symbol
146     (string-append prefix "/" name))))
147
148(define (extract-error-sources error-list)
149  (map error-string->pair
150       (filter (lambda (str)
151                 (and (string-prefix? "GPG_ERR_SOURCE" str)
152                      (string-index str #\=)))
153               error-list)))
154
155(define (extract-error-codes error-list)
156  (map error-string->pair
157       (filter (lambda (str)
158                 (and (string-prefix? "GPG_ERR" str)
159                      (not (string-prefix? "GPG_ERR_SOURCE" str))
160                      (string-index str #\=)))
161               error-list)))
162
163(define (output-error-code-define error-pair)
164  (let ((name (c-error-name->symbol (car error-pair)))
165        (value (cdr error-pair))
166        (description (error-code->description
167                      (cdr error-pair))))
168    `(define-public ,name (make-error-code ,value ,description))))
169
170(define (output-error-source-define error-pair)
171  (let ((name (c-error-name->symbol (car error-pair)))
172        (value (cdr error-pair))
173        (description (error-source->description
174                      (cdr error-pair))))
175    `(define-public ,name (make-error-source ,value ,description))))
176
177(define (extract-error-decls lines)
178  (map
179   (lambda (line)
180     (string-trim-both line (char-set-adjoin char-set:whitespace #\,)))
181   (filter (lambda (line)
182             (string-match "^[[:space:]]*GPG_ERR_.*[[:digit:]],?" line))
183           lines)))
184
185(define (output-error-code-dim input dim-value)
186  (regexp-substitute
187   #f (string-match "@@ERROR_CODE_DIM@@" input)
188   'pre dim-value 'post))
189
190(define (output-error-code-decls input decls)
191  (regexp-substitute
192   #f (string-match "@@ERROR_CODE_DECLS@@" input)
193   'pre decls 'post))
194
195(define (output-error-code-lookup input lookups)
196  (let ((l (string-append
197            "   `"
198            (substring
199             (regexp-substitute/global
200              #f
201              "(error-code/)"
202              (with-output-to-string
203                (lambda ()
204                  (pretty-print
205                   (let loop ((rest lookups)
206                              (done '()))
207                     (if (null? rest)
208                         (reverse done)
209                         (loop (cdr rest)
210                               (if (string= (caar rest) "GPG_ERR_CODE_DIM")
211                                   done
212                                   (cons
213                                    (cons (cdar rest)
214                                          (c-error-name->symbol (caar rest)))
215                                    done)))))
216                   #:per-line-prefix "    ")))
217              'pre "," 1 'post)
218             4))))
219    (regexp-substitute
220     #f (string-match "@@ERROR_CODE_LOOKUP@@" input)
221     'pre l 'post)))
222
223(define (output-error-source-dim input dim-value)
224  (regexp-substitute
225   #f (string-match "@@ERROR_SOURCE_DIM@@" input)
226   'pre dim-value 'post))
227
228(define (output-error-source-decls input decls)
229  (regexp-substitute
230   #f (string-match "@@ERROR_SOURCE_DECLS@@" input)
231   'pre decls 'post))
232
233(define (output-error-source-lookup input lookups)
234  (let ((l (string-append
235            "   `"
236            (substring
237             (regexp-substitute/global
238              #f
239              "(error-source/)"
240              (with-output-to-string
241                (lambda ()
242                  (pretty-print
243                   (let loop ((rest lookups)
244                              (done '()))
245                     (if (null? rest)
246                         (reverse done)
247                         (loop (cdr rest)
248                               (if (string= (caar rest) "GPG_ERR_SOURCE_DIM")
249                                   done
250                                   (cons
251                                    (cons (cdar rest)
252                                          (c-error-name->symbol (caar rest)))
253                                    done)))))
254                   #:per-line-prefix "    ")))
255              'pre "," 1 'post)
256             4))))
257    (regexp-substitute
258     #f (string-match "@@ERROR_SOURCE_LOOKUP@@" input)
259     'pre l 'post)))
260
261(define (main . args)
262  (let* ((error-decls
263          (extract-error-decls
264           (let ((p (open-input-file (string-append
265                                      *libgpg-error-prefix*
266                                      "/gpg-error.h"))))
267             (let loop ((line (read-line p))
268                        (lines '()))
269               (if (eof-object? line)
270                   (begin
271                     (close-port p)
272                     (reverse lines))
273                   (loop (read-line p)
274                         (cons line lines)))))))
275         ;; error codes
276         (error-codes (extract-error-codes error-decls))
277         (error-code-defines
278          (with-output-to-string
279            (lambda ()
280              (for-each
281               (lambda (defn)
282                 (if (not (string=
283                           (car defn)
284                           "GPG_ERR_CODE_DIM"))
285                     (pretty-print (output-error-code-define defn))
286                     (display "")))
287               error-codes))))
288         ;; error sources
289         (error-sources (extract-error-sources error-decls))
290         (error-source-defines
291          (with-output-to-string
292            (lambda ()
293              (for-each
294               (lambda (defn)
295                 (if (not (string=
296                           (car defn)
297                           "GPG_ERR_SOURCE_DIM"))
298                     (pretty-print (output-error-source-define defn))
299                     (display "")))
300               error-sources))))
301         ;; input files
302         (error-codes.scm.in
303          (let* ((p (open-input-file
304                     "../src/gpg/error-codes.scm.in" #:binary #t))
305                 (bv (get-bytevector-all p)))
306            (close-port p)
307            (utf8->string bv)))
308         (error-sources.scm.in
309          (let* ((p (open-input-file
310                     "../src/gpg/error-sources.scm.in" #:binary #t))
311                 (bv (get-bytevector-all p)))
312            (close-port p)
313            (utf8->string bv)))
314         ;; output-files
315         (error-codes.scm
316          (open-output-file "../src/gpg/error-codes.scm" #:binary #t))
317         (error-sources.scm
318          (open-output-file "../src/gpg/error-sources.scm" #:binary #t)))
319    (put-bytevector
320     error-codes.scm
321     (string->utf8
322      (output-error-code-lookup
323       (output-error-code-decls
324        (output-error-code-dim
325         error-codes.scm.in
326         (number->string (assoc-ref error-codes "GPG_ERR_CODE_DIM")))
327        error-code-defines)
328       error-codes)))
329    (close-port error-codes.scm)
330    (put-bytevector
331     error-sources.scm
332     (string->utf8
333      (output-error-source-lookup
334       (output-error-source-decls
335        (output-error-source-dim
336         error-sources.scm.in
337         (number->string (assoc-ref error-sources "GPG_ERR_SOURCE_DIM")))
338        error-source-defines)
339       error-sources)))
340    (close-port error-sources.scm)))
341
342;; Local Variables:
343;; mode: scheme
344;; End:
345;;; err-setup.scm ends here