GpgFrontend/gpgme
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cl: Several fixes

Browse Source 
--

* Use wrapper types calling translation functions instead of
  TRANSLATE-{FROM,TO}-FOREIGN methods as they seem not to be
  called in some cases.
* Use the (:STRUCT SOME-C-STRUCT) notation instead of the
  deprecated direct reference to SOME-C-STRUCT.
* Add missing values in enums and bit fields.
* Use cffi-grovel to define system types (SIZE-T, OFF-T, etc).
* Wrap GPGME-DATA-T in a class (like contexts).
* Use the FINALIZE function from trivial-garbage to free the
  C objects for contexts, keys and data automatically.
* Make DATA-READ-CB and DATA-WRITE-CB run faster.
* Update the README file.

Signed-off-by: Guillaume LE VAILLANT <glv@posteo.net>
This commit is contained in:
Guillaume LE VAILLANT 2018-10-12 08:49:26 +02:00 committed by Werner Koch
parent aafadb8594
commit 85d7af8ff2
No known key found for this signature in database
GPG Key ID: E3FDFF218E45B72B
5 changed files with 386 additions and 173 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
lang/cl/Makefile.am
View File

@ -18,7 +18,7 @@
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
# 02111-1307, USA
clfiles = gpgme.asd gpgme-package.lisp gpgme.lisp
clfiles = gpgme.asd gpgme-package.lisp gpgme-grovel.lisp gpgme.lisp
# FIXME: Should be configurable.
clfilesdir = $(datadir)/common-lisp/source/gpgme

33
lang/cl/README
View File

@ -3,33 +3,50 @@ Common Lisp Support for GPGME
Requirements:
ASDF Packaging Support
CFFI Foreign Function Interface
gpg-error GPG Error Codes
ASDF Packaging Support
CFFI Foreign Function Interface
trivial-garbage Finalizers
gpg-error GPG Error Codes
Use with:
> (asdf:operate 'asdf:load-op ':gpgme)
> (asdf:load-system "gpgme")
Examples
--------
(with-open-file (stream "/tmp/myout" :direction :output
:if-exists :supersede :element-type '(unsigned-byte 8))
(with-open-file (out "/tmp/myout"
:direction :output
:if-exists :supersede
:element-type '(unsigned-byte 8))
(with-context (ctx)
(setf (armor-p ctx) t)
(setf (armorp ctx) t)
(op-export ctx "DEADBEEF" out)))
(with-context (ctx)
(with-output-to-string (out)
(setf (armor-p ctx) t)
(setf (armorp ctx) t)
(op-export ctx "McTester" out)))
(gpgme:with-context (ctx :armor t)
(with-output-to-string (out)
(gpgme:op-export ctx "McTester" out)))
(gpgme:with-context (ctx :armor t)
(let ((recipient1 (gpgme:get-key ctx "DEADBEEF"))
(recipient2 (gpgme:get-key ctx "Alice"))
(message "Hello, world!"))
(with-output-to-string (out)
(with-input-from-string (in message)
(gpgme:op-encrypt ctx (vector recipient1 recipient2) in out)))))
(gpgme:with-context (ctx :armor t)
(let ((message "Hello, world!"))
(with-output-to-string (out)
(with-input-from-string (in message)
(gpgme:op-sign ctx in out)))))
TODO
----

3
lang/cl/gpgme-package.lisp
View File

@ -26,7 +26,8 @@
(defpackage #:gpgme
(:use #:common-lisp #:cffi #:gpg-error)
(:import-from #:trivial-garbage
#:finalize)
(:export #:check-version
#:*version*
#:context

19
lang/cl/gpgme.asd.in
View File

@ -25,11 +25,14 @@
(in-package #:gpgme-system)
(defsystem gpgme
:description "GnuPG Made Easy."
:author "g10 Code GmbH"
:version "@VERSION@"
:licence "GPL"
:depends-on ("cffi" "gpg-error")
:components ((:file "gpgme-package")
(:file "gpgme"
:depends-on ("gpgme-package"))))
:description "GnuPG Made Easy."
:author "g10 Code GmbH"
:version "@VERSION@"
:licence "GPL"
:defsystem-depends-on ("cffi-grovel")
:depends-on ("cffi" "gpg-error" "trivial-garbage")
:components ((:file "gpgme-package")
(:cffi-grovel-file "gpgme-grovel"
:depends-on ("gpgme-package"))
(:file "gpgme"
:depends-on ("gpgme-package" "gpgme-grovel"))))

502
lang/cl/gpgme.lisp
View File

@ -24,6 +24,12 @@
(in-package :gpgme)
(deftype byte-array ()
'(simple-array (unsigned-byte 8) (*)))
(deftype character-array ()
'(simple-array character (*)))
;;; Debugging.
(defvar *debug* nil "If debugging output should be given or not.")
@ -38,23 +44,15 @@
;;; System dependencies.
; FIXME: Use cffi-grovel? cffi-unix?
(defctype size-t :unsigned-int "The system size_t type.")
(defctype ssize-t :int "The system ssize_t type.")
; FIXME: Ouch. Grovel? Helper function?
(defconstant +seek-set+ 0)
(defconstant +seek-cur+ 1)
(defconstant +seek-end+ 2)
(defctype off-t :long-long "The system off_t type.")
; Access to ERRNO.
(defcfun ("strerror" c-strerror) :string
(err :int))
; Access to ERRNO.
; FIXME: Ouch. Should be grovel + helper function.
(defun get-errno ()
*errno*)
(defun set-errno (errno)
(setf *errno* errno))
(define-condition system-error (error)
((errno :initarg :errno :reader system-error-errno))
@ -64,14 +62,6 @@
(c-strerror (system-error-errno c)))))
(:documentation "Signalled when an errno is encountered."))
(defconstant +ebadf+ 1)
; Ouch.
(defun get-errno ()
+ebadf+)
;;; More about errno below.
; Needed to write passphrases.
(defcfun ("write" c-write) ssize-t
(fd :int)
@ -83,14 +73,6 @@
(when (< res 0) (error 'system-error :errno (get-errno)))
res))
;;; More about errno here.
(defun set-errno (errno)
(cond
; Works on GNU/Linux.
((eql errno +ebadf+) (system-write -1 (null-pointer) 0))
(t (error 'invalid-errno :errno errno))))
;;;
;;; C Interface Definitions
;;;
@ -100,22 +82,39 @@
;;; Some new data types used for easier translation.
;;; The number of include certs. Translates to NIL for default.
(defctype cert-int-t :int)
(defctype cert-int-t
(:wrapper :int
:from-c translate-cert-int-t-from-foreign
:to-c translate-cert-int-t-to-foreign))
;;; A string that may be NIL to indicate a null pointer.
(defctype string-or-nil-t :string)
(defctype string-or-nil-t
(:wrapper :string
:to-c translate-string-or-nil-t-to-foreign))
;;; Some opaque data types used by GPGME.
(defctype gpgme-ctx-t :pointer "The GPGME context type.")
(defctype gpgme-ctx-t
(:wrapper :pointer
:to-c translate-gpgme-ctx-t-to-foreign)
"The GPGME context type.")
(defctype gpgme-data-t :pointer "The GPGME data object type.")
(defctype gpgme-data-t
(:wrapper :pointer
:to-c translate-gpgme-data-t-to-foreign)
"The GPGME data object type.")
;;; Wrappers for the libgpg-error library.
(defctype gpgme-error-t gpg-error::gpg-error-t "The GPGME error type.")
(defctype gpgme-error-t
(:wrapper gpg-error::gpg-error-t
:from-c translate-gpgme-error-t-from-foreign
:to-c translate-gpgme-error-t-to-foreign)
"The GPGME error type.")
(defctype gpgme-error-no-signal-t gpg-error::gpg-error-t
(defctype gpgme-error-no-signal-t
(:wrapper gpg-error::gpg-error-t
:from-c translate-gpgme-error-no-signal-t-from-foreign)
"The GPGME error type (this version does not signal conditions in translation.")
(defctype gpgme-err-code-t gpg-error::gpg-err-code-t
@ -171,7 +170,11 @@
(:none 0)
(:binary 1)
(:base64 2)
(:armor 3))
(:armor 3)
(:url 4)
(:urlesc 5)
(:url0 6)
(:mime 7))
;;;
@ -182,7 +185,11 @@
(:rsa-s 3)
(:elg-e 16)
(:dsa 17)
(:elg 20))
(:ecc 18)
(:elg 20)
(:ecdsa 301)
(:ecdh 302)
(:eddsa 303))
(defcenum gpgme-hash-algo-t
"Hash algorithms from libgcrypt."
@ -196,6 +203,7 @@
(:sha256 8)
(:sha384 9)
(:sha512 10)
(:sha224 11)
(:md4 301)
(:crc32 302)
(:crc32-rfc1510 303)
@ -225,7 +233,14 @@
(defcenum gpgme-protocol-t
"The available protocols."
(:openpgp 0)
(:cms 1))
(:cms 1)
(:gpgconf 2)
(:assuan 3)
(:g13 4)
(:uiserver 5)
(:spawn 6)
(:default 254)
(:unknown 255))
;;;
@ -234,6 +249,10 @@
(:local 1)
(:extern 2)
(:sigs 4)
(:sig-notations)
(:with-secret 16)
(:with-tofu 32)
(:ephemeral 128)
(:validate 256))
;;;
@ -243,7 +262,9 @@
(:human-readable 1)
(:critical 2))
(defctype gpgme-sig-notation-t :pointer
(defctype gpgme-sig-notation-t
(:wrapper :pointer
:from-c translate-gpgme-sig-notation-t-from-foreign)
"Signature notation pointer type.")
;; FIXME: Doesn't this depend on endianess?
@ -263,15 +284,115 @@
;;;
;; FIXME: Add status codes.
(defcenum gpgme-status-code-t
"The possible status codes for the edit operation."
(:eof 0)
(:enter 1))
(:enter 1)
(:leave 2)
(:abort 3)
(:goodsig 4)
(:badsig 5)
(:errsig 6)
(:badarmor 7)
(:rsa-or-idea 8)
(:keyexpired 9)
(:keyrevoked 10)
(:trust-undefined 11)
(:trust-never 12)
(:trust-marginal 13)
(:trust-fully 14)
(:trust-ultimate 15)
(:shm-info 16)
(:shm-get 17)
(:shm-get-bool 18)
(:shm-get-hidden 19)
(:need-passphrase 20)
(:validsig 21)
(:sig-id 22)
(:enc-to 23)
(:nodata 24)
(:bad-passphrase 25)
(:no-pubkey 26)
(:no-seckey 27)
(:need-passphrase-sym 28)
(:decryption-failed 29)
(:decryption-okay 30)
(:missing-passphrase 31)
(:good-passphrase 32)
(:goodmdc 33)
(:badmdc 34)
(:errmdc 35)
(:imported 36)
(:import-ok 37)
(:import-problem 38)
(:import-res 39)
(:file-start 40)
(:file-done 41)
(:file-error 42)
(:begin-decryption 43)
(:end-decryption 44)
(:begin-encryption 45)
(:end-encryption 46)
(:delete-problem 47)
(:get-bool 48)
(:get-line 49)
(:get-hidden 50)
(:got-it 51)
(:progress 52)
(:sig-created 53)
(:session-key 54)
(:notation-name 55)
(:notation-data 56)
(:policy-url 57)
(:begin-stream 58)
(:end-stream 59)
(:key-created 60)
(:userid-hint 61)
(:unexpected 62)
(:inv-recp 63)
(:no-recp 64)
(:already-signed 65)
(:sigexpired 66)
(:expsig 67)
(:expkeysig 68)
(:truncated 69)
(:error 70)
(:newsig 71)
(:revkeysig 72)
(:sig-subpacket 73)
(:need-passphrase-pin 74)
(:sc-op-failure 75)
(:sc-op-success 76)
(:cardctrl 77)
(:backup-key-created 78)
(:pka-trust-bad 79)
(:pka-trust-good 80)
(:plaintext 81)
(:inv-sgnr 82)
(:no-sgnr 83)
(:success 84)
(:decryption-info 85)
(:plaintext-length 86)
(:mountpoint 87)
(:pinentry-launched 88)
(:attribute 89)
(:begin-signing 90)
(:key-not-created 91)
(:inquire-maxlen 92)
(:failure 93)
(:key-considered 94)
(:tofu-user 95)
(:tofu-stats 96)
(:tofu-stats-long 97)
(:notation-flags 98)
(:decryption-compliance-mode 99)
(:verification-compliance-mode 100))
;;;
(defctype gpgme-engine-info-t :pointer
(defctype gpgme-engine-info-t
(:wrapper :pointer
:from-c translate-gpgme-engine-info-t-to-foreign)
"The engine information structure pointer type.")
(defcstruct gpgme-engine-info
@ -285,7 +406,10 @@
;;;
(defctype gpgme-subkey-t :pointer "A subkey from a key.")
(defctype gpgme-subkey-t
(:wrapper :pointer
:from-c translate-gpgme-subkey-t-from-foreign)
"A subkey from a key.")
;; FIXME: Doesn't this depend on endianess?
(defbitfield (gpgme-subkey-bitfield :unsigned-int)
@ -299,7 +423,9 @@
(:can-certify 64)
(:secret 128)
(:can-authenticate 256)
(:is-qualified 512))
(:is-qualified 512)
(:is-cardkey 1024)
(:is-de-vs 2048))
(defcstruct gpgme-subkey
"Subkey from a key."
@ -314,7 +440,9 @@
(expires :long))
(defctype gpgme-key-sig-t :pointer
(defctype gpgme-key-sig-t
(:wrapper :pointer
:from-c translate-gpgme-key-sig-t-from-foreign)
"A signature on a user ID.")
;; FIXME: Doesn't this depend on endianess?
@ -343,7 +471,9 @@
(sig-class :unsigned-int))
(defctype gpgme-user-id-t :pointer
(defctype gpgme-user-id-t
(:wrapper :pointer
:from-c translate-gpgme-user-id-t-from-foreign)
"A user ID from a key.")
;; FIXME: Doesn't this depend on endianess?
@ -365,7 +495,10 @@
(-last-keysig gpgme-key-sig-t))
(defctype gpgme-key-t :pointer
(defctype gpgme-key-t
(:wrapper :pointer
:from-c translate-gpgme-key-t-from-foreign
:to-c translate-gpgme-key-t-to-foreign)
"A key from the keyring.")
;; FIXME: Doesn't this depend on endianess?
@ -693,7 +826,9 @@
;;;
(defctype gpgme-invalid-key-t :pointer
(defctype gpgme-invalid-key-t
(:wrapper :pointer
:from-c translate-gpgme-invalid-key-t-from-foreign)
"An invalid key structure.")
(defcstruct gpgme-invalid-key
@ -708,7 +843,9 @@
"Encryption result structure."
(invalid-recipients gpgme-invalid-key-t))
(defctype gpgme-op-encrypt-result-t :pointer
(defctype gpgme-op-encrypt-result-t
(:wrapper :pointer
:from-c translate-gpgme-op-encrypt-result-t-from-foreign)
"An encryption result structure.")
(defcfun ("gpgme_op_encrypt_result" c-gpgme-op-encrypt-result)
@ -716,7 +853,15 @@
(ctx gpgme-ctx-t))
(defbitfield gpgme-encrypt-flags-t
(:always-trust 1))
(:always-trust 1)
(:no-encrypt-to 2)
(:prepare 4)
(:expect-sign 8)
(:no-compress 16)
(:symmetric 32)
(:throw-keyids 64)
(:wrap 128)
(:want-address 256))
(defcfun ("gpgme_op_encrypt_start" c-gpgme-op-encrypt-start) gpgme-error-t
(ctx gpgme-ctx-t)
@ -749,7 +894,9 @@
;;; Decryption.
(defctype gpgme-recipient-t :pointer
(defctype gpgme-recipient-t
(:wrapper :pointer
:from-c translate-gpgme-recipient-t-from-foreign)
"A recipient structure.")
(defcstruct gpgme-recipient
@ -762,7 +909,9 @@
(defbitfield gpgme-op-decrypt-result-bitfield
"Decryption result structure bitfield."
(:wrong-key-usage 1))
(:wrong-key-usage 1)
(:is-de-vs 2)
(:is-mine 4))
(defcstruct gpgme-op-decrypt-result
"Decryption result structure."
@ -771,7 +920,9 @@
(recipients gpgme-recipient-t)
(file-name :string))
(defctype gpgme-op-decrypt-result-t :pointer
(defctype gpgme-op-decrypt-result-t
(:wrapper :pointer
:from-c translate-gpgme-op-decrypt-result-t-from-foreign)
"A decryption result structure.")
(defcfun ("gpgme_op_decrypt_result" c-gpgme-op-decrypt-result)
@ -801,7 +952,9 @@
;;; Signing.
(defctype gpgme-new-signature-t :pointer
(defctype gpgme-new-signature-t
(:wrapper :pointer
:from-c translate-gpgme-new-signature-t-from-foreign)
"A new signature structure.")
(defcstruct gpgme-new-signature
@ -821,7 +974,9 @@
(invalid-signers gpgme-invalid-key-t)
(signatures gpgme-new-signature-t))
(defctype gpgme-op-sign-result-t :pointer
(defctype gpgme-op-sign-result-t
(:wrapper :pointer
:from-c translate-gpgme-op-sign-result-t-from-foreign)
"A signing result structure.")
(defcfun ("gpgme_op_sign_result" c-gpgme-op-sign-result)
@ -854,15 +1009,21 @@
(:crl-missing #x0100)
(:crl-too-old #x0200)
(:bad-policy #x0400)
(:sys-error #x0800))
(:sys-error #x0800)
(:tofu-conflict #x1000))
(defctype gpgme-signature-t :pointer
(defctype gpgme-signature-t
(:wrapper :pointer
:from-c translate-gpgme-signature-t-from-foreign)
"A signature structure.")
;; FIXME: Doesn't this depend on endianess?
(defbitfield (gpgme-signature-bitfield :unsigned-int)
"The signature bitfield."
(:wrong-key-usage 1))
(:wrong-key-usage 1)
(:pka-trust 2)
(:chain-model 4)
(:is-de-vs 8))
(defcstruct gpgme-signature
"Signature structure."
@ -884,7 +1045,9 @@
(signatures gpgme-signature-t)
(file-name :string))
(defctype gpgme-op-verify-result-t :pointer
(defctype gpgme-op-verify-result-t
(:wrapper :pointer
:from-c translate-gpgme-op-verify-result-t-from-foreign)
"A verify result structure.")
(defcfun ("gpgme_op_verify_result" c-gpgme-op-verify-result)
@ -913,7 +1076,9 @@
(:subkey #x0008)
(:secret #x0010))
(defctype gpgme-import-status-t :pointer
(defctype gpgme-import-status-t
(:wrapper :pointer
:from-c translate-gpgme-import-status-t-from-foreign)
"An import status structure.")
(defcstruct gpgme-import-status
@ -941,7 +1106,9 @@
(not-imported :int)
(imports gpgme-import-status-t))
(defctype gpgme-op-import-result-t :pointer
(defctype gpgme-op-import-result-t
(:wrapper :pointer
:from-c translate-gpgme-op-import-result-t-from-foreign)
"An import status result structure.")
(defcfun ("gpgme_op_import_result" c-gpgme-op-import-result)
@ -977,7 +1144,8 @@
(defbitfield (gpgme-genkey-flags-t :unsigned-int)
"Flags used for the key generation result bitfield."
(:primary #x0001)
(:sub #x0002))
(:sub #x0002)
(:uid #x0004))
(defcstruct gpgme-op-genkey-result
"Key generation result structure."
@ -1078,21 +1246,20 @@
;;; cert-int-t is a helper type that takes care of representing the
;;; default number of certs as NIL.
(defmethod translate-from-foreign (value (type (eql 'cert-int-t)))
(defun translate-cert-int-t-from-foreign (value)
(cond
((eql value +include-certs-default+) nil)
(t value)))
(defmethod translate-to-foreign (value (type (eql 'cert-int-t)))
(defun translate-cert-int-t-to-foreign (value)
(cond
(value value)
(t +include-certs-default+)))
;;; string-or-nil-t translates a null pointer to NIL and vice versa.
;;; Translation from foreign null pointer already works as expected.
;;; FIXME: May the "to foreign" conversion problem be a bug in CFFI?
(defmethod translate-to-foreign (value (type (eql 'string-or-nil-t)))
(defun translate-string-or-nil-t-to-foreign (value)
(cond
(value value)
(t (null-pointer))))
@ -1109,12 +1276,12 @@
;;; FIXME: Should we use a hash table (or struct, or clos) instead of
;;; property list, as recommended by the Lisp FAQ?
(defmethod translate-from-foreign (value (type (eql 'gpgme-engine-info-t)))
(defun translate-gpgme-engine-info-t-from-foreign (value)
(cond
((null-pointer-p value) nil)
(t (with-foreign-slots
((next protocol file-name version req-version home-dir)
value gpgme-engine-info)
value (:struct gpgme-engine-info))
(append (list protocol (list
:file-name file-name
:version version
@ -1122,55 +1289,53 @@
:home-dir home-dir))
next)))))
(defmethod translate-from-foreign (value (type (eql 'gpgme-invalid-key-t)))
(defun translate-gpgme-invalid-key-t-from-foreign (value)
(cond
((null-pointer-p value) nil)
(t (with-foreign-slots
((next fpr reason)
value gpgme-invalid-key)
value (:struct gpgme-invalid-key))
(append (list (list :fpr fpr
:reason reason))
next)))))
(defmethod translate-from-foreign (value
(type (eql 'gpgme-op-encrypt-result-t)))
(defun translate-gpgme-op-encrypt-result-t-from-foreign (value)
(cond
((null-pointer-p value) nil)
(t (with-foreign-slots
((invalid-recipients)
value gpgme-op-encrypt-result)
value (:struct gpgme-op-encrypt-result))
(list :encrypt
(list :invalid-recipients invalid-recipients))))))
(defmethod translate-from-foreign (value (type (eql 'gpgme-recipient-t)))
(defun translate-gpgme-recipient-t-from-foreign (value)
(cond
((null-pointer-p value) nil)
(t (with-foreign-slots
((next keyid pubkey-algo status)
value gpgme-recipient)
value (:struct gpgme-recipient))
(append (list (list :keyid keyid
:pubkey-algo pubkey-algo
:status status))
next)))))
(defmethod translate-from-foreign (value
(type (eql 'gpgme-op-decrypt-result-t)))
(defun translate-gpgme-op-decrypt-result-t-from-foreign (value)
(cond
((null-pointer-p value) nil)
(t (with-foreign-slots
((unsupported-algorithm bitfield recipients file-name)
value gpgme-op-decrypt-result)
value (:struct gpgme-op-decrypt-result))
(list :decrypt (list :unsupported-algorithm unsupported-algorithm
:bitfield bitfield
:recipients recipients
:file-name file-name))))))
(defmethod translate-from-foreign (value (type (eql 'gpgme-new-signature-t)))
(defun translate-gpgme-new-signature-t-from-foreign (value)
(cond
((null-pointer-p value) nil)
(t (with-foreign-slots
((next type pubkey-algo hash-algo timestamp fpr sig-class)
value gpgme-new-signature)
value (:struct gpgme-new-signature))
(append (list (list :type type
:pubkey-algo pubkey-algo
:hash-algo hash-algo
@ -1179,24 +1344,23 @@
:sig-class sig-class))
next)))))
(defmethod translate-from-foreign (value
(type (eql 'gpgme-op-sign-result-t)))
(defun translate-gpgme-op-sign-result-t-from-foreign (value)
(cond
((null-pointer-p value) nil)
(t (with-foreign-slots
((invalid-signers signatures)
value gpgme-op-sign-result)
value (:struct gpgme-op-sign-result))
(list :sign (list :invalid-signers invalid-signers
:signatures signatures))))))
(defmethod translate-from-foreign (value (type (eql 'gpgme-signature-t)))
(defun translate-gpgme-signature-t-from-foreign (value)
(cond
((null-pointer-p value) nil)
(t (with-foreign-slots
((next summary fpr status notations timestamp
exp-timestamp bitfield validity validity-reason
pubkey-algo hash-algo)
value gpgme-signature)
value (:struct gpgme-signature))
(append (list (list :summary summary
:fpr fpr
:status status
@ -1209,29 +1373,27 @@
:pubkey-algo pubkey-algo))
next)))))
(defmethod translate-from-foreign (value
(type (eql 'gpgme-op-verify-result-t)))
(defun translate-gpgme-op-verify-result-t-from-foreign (value)
(cond
((null-pointer-p value) nil)
(t (with-foreign-slots
((signatures file-name)
value gpgme-op-verify-result)
value (:struct gpgme-op-verify-result))
(list :verify (list :signatures signatures
:file-name file-name))))))
(defmethod translate-from-foreign (value (type (eql 'gpgme-import-status-t)))
(defun translate-gpgme-import-status-t-from-foreign (value)
(cond
((null-pointer-p value) nil)
(t (with-foreign-slots
((next fpr result status)
value gpgme-import-status)
value (:struct gpgme-import-status))
(append (list (list :fpr fpr
:result result
:status status))
next)))))
(defmethod translate-from-foreign (value
(type (eql 'gpgme-op-import-result-t)))
(defun translate-gpgme-op-import-result-t-from-foreign (value)
(cond
((null-pointer-p value) nil)
(t (with-foreign-slots
@ -1240,7 +1402,7 @@
new-revocations secret-read secret-imported
secret-unchanged skipped-new-keys not-imported
imports)
value gpgme-op-import-result)
value (:struct gpgme-op-import-result))
(list :verify (list :considered considered
:no-user-id no-user-id
:imported imported
@ -1272,19 +1434,19 @@
(gpgme-strsource (gpgme-error-value c)))))
(:documentation "Signalled when a GPGME function returns an error."))
(defmethod translate-from-foreign (value (name (eql 'gpgme-error-t)))
(defun translate-gpgme-error-t-from-foreign (value)
"Raise a GPGME-ERROR if VALUE is non-zero."
(when (not (eql (gpgme-err-code value) :gpg-err-no-error))
(error 'gpgme-error :gpgme-error value))
(gpg-err-canonicalize value))
(defmethod translate-to-foreign (value (name (eql 'gpgme-error-t)))
(defun translate-gpgme-error-t-to-foreign (value)
"Canonicalize the error value."
(if (eql (gpgme-err-code value) :gpg-err-no-error)
0
(gpg-err-as-value value)))
(defmethod translate-from-foreign (value (name (eql 'gpgme-error-no-signal-t)))
(defun translate-gpgme-error-no-signal-t-from-foreign (value)
"Canonicalize the error value."
(gpg-err-canonicalize value))
@ -1528,61 +1690,68 @@
(when (not (null-pointer-p handle)) (foreign-free handle))))
(defcallback data-read-cb ssize-t ((handle :pointer) (buffer :pointer)
(size size-t))
(size size-t))
(when *debug* (format t "DEBUG: gpgme-data-read-cb: want ~A~%" size))
(let ((stream (gethash (pointer-address handle) *data-handles*)))
(cond
(stream
(let* ((stream-type (stream-element-type stream))
(seq (make-array size :element-type stream-type))
(read (read-sequence seq stream)))
(loop for i from 0 to (- read 1)
do (setf (mem-aref buffer :unsigned-char i)
;;; FIXME: This is a half-assed attempt at
;;; supporting character streams.
(cond
((eql stream-type 'character)
(char-code (elt seq i)))
(t (coerce (elt seq i) stream-type)))))
(when *debug* (format t "DEBUG: gpgme-data-read-cb: read ~A~%" read))
read))
(t (set-errno +ebadf+)
-1))))
(seq (make-array size :element-type stream-type))
(read (read-sequence seq stream)))
(cond
((equal stream-type '(unsigned-byte 8))
(dotimes (i read)
(setf (mem-aref buffer :unsigned-char i)
(aref (the byte-array seq) i))))
((eql stream-type 'character)
(dotimes (i read)
(setf (mem-aref buffer :unsigned-char i)
(char-code (aref (the character-array seq) i)))))
(t
(dotimes (i read)
(setf (mem-aref buffer :unsigned-char i)
(coerce (aref seq i) '(unsigned-byte 8))))))
(when *debug* (format t "DEBUG: gpgme-data-read-cb: read ~A~%" read))
read))
(t
(set-errno +ebadf+)
-1))))
(defcallback data-write-cb ssize-t ((handle :pointer) (buffer :pointer)
(size size-t))
(size size-t))
(when *debug* (format t "DEBUG: gpgme-data-write-cb: want ~A~%" size))
(let ((stream (gethash (pointer-address handle) *data-handles*)))
(cond
(stream
(let* ((stream-type (stream-element-type stream))
(seq (make-array size :element-type stream-type)))
(loop for i from 0 to (- size 1)
do (setf (elt seq i)
;;; FIXME: This is a half-assed attempt at
;;; supporting character streams.
(cond
((eql stream-type 'character)
(code-char (mem-aref buffer :unsigned-char i)))
(t (coerce (mem-aref buffer :unsigned-char i)
stream-type)))))
(write-sequence seq stream)
;;; FIXME: What about write errors?
size))
(t (set-errno +ebadf+)
-1))))
(seq (make-array size :element-type stream-type)))
(cond
((equal stream-type '(unsigned-byte 8))
(dotimes (i size)
(setf (aref (the byte-array seq) i)
(mem-aref buffer :unsigned-char i))))
((eql stream-type 'character)
(dotimes (i size)
(setf (aref (the character-array seq) i)
(code-char (mem-aref buffer :unsigned-char i)))))
(t
(dotimes (i size)
(setf (aref seq i)
(coerce (mem-aref buffer :unsigned-char i) stream-type)))))
(write-sequence seq stream)
size))
(t
(set-errno +ebadf+)
-1))))
;;; This little helper macro allows us to swallow the cbs structure by
;;; simply setting it to a null pointer, but still protect against
;;; conditions.
(defmacro with-cbs-swallowed ((cbs) &body body)
`(let ((,cbs (foreign-alloc 'gpgme-data-cbs)))
`(let ((,cbs (foreign-alloc '(:struct gpgme-data-cbs))))
(unwind-protect (progn ,@body)
(when (not (null-pointer-p ,cbs)) (foreign-free ,cbs)))))
;;; FIXME: Wrap the object and attach to it a finalizer. Requires new
;;; CFFI. Should we use an OO interface, ie make-instance? For now,
;;; we do not provide direct access to data objects.
(defun gpgme-data-new (stream &key encoding file-name)
"Allocate a new GPGME data object for STREAM."
(with-foreign-object (dh-p 'gpgme-data-t)
@ -1592,12 +1761,14 @@
;;; unique C pointer as handle anyway to look up the stream in the
;;; callback. This is a convenient one to use.
(with-cbs-swallowed (cbs)
(setf
(foreign-slot-value cbs 'gpgme-data-cbs 'read) (callback data-read-cb)
(foreign-slot-value cbs 'gpgme-data-cbs 'write) (callback data-write-cb)
(foreign-slot-value cbs 'gpgme-data-cbs 'seek) (null-pointer)
(foreign-slot-value cbs 'gpgme-data-cbs 'release) (callback
data-release-cb))
(setf (foreign-slot-value cbs '(:struct gpgme-data-cbs) 'read)
(callback data-read-cb))
(setf (foreign-slot-value cbs '(:struct gpgme-data-cbs) 'write)
(callback data-write-cb))
(setf (foreign-slot-value cbs '(:struct gpgme-data-cbs) 'seek)
(null-pointer))
(setf (foreign-slot-value cbs '(:struct gpgme-data-cbs) 'release)
(callback data-release-cb))
(c-gpgme-data-new-from-cbs dh-p cbs cbs)
(let ((dh (mem-ref dh-p 'gpgme-data-t)))
(when encoding (gpgme-data-set-encoding dh encoding))
@ -1619,12 +1790,33 @@
(when *debug* (format t "DEBUG: gpgme-data-release: ~A~%" dh))
(c-gpgme-data-release dh))
(defclass data ()
(c-data) ; The C data object pointer
(:documentation "The GPGME data type."))
(defmethod initialize-instance :after ((data data) &key streamspec
&allow-other-keys)
(let ((c-data (if (listp streamspec)
(apply #'gpgme-data-new streamspec)
(gpgme-data-new streamspec)))
(cleanup t))
(unwind-protect
(progn
(setf (slot-value data 'c-data) c-data)
(finalize data (lambda () (gpgme-data-release c-data)))
(setf cleanup nil))
(if cleanup (gpgme-data-release c-data)))))
(defun translate-gpgme-data-t-to-foreign (value)
;; Allow a pointer to be passed directly for the finalizer to work.
(cond
((null value) (null-pointer))
((pointerp value) value)
(t (slot-value value 'c-data))))
(defmacro with-gpgme-data ((dh streamspec) &body body)
`(let ((,dh (if (listp ,streamspec)
(apply 'gpgme-data-new ,streamspec)
(gpgme-data-new ,streamspec))))
(unwind-protect (progn ,@body)
(when (not (null-pointer-p ,dh)) (gpgme-data-release ,dh)))))
`(let ((,dh (make-instance 'data :streamspec ,streamspec)))
,@body))
(defun gpgme-data-get-encoding (dh)
"Get the encoding associated with the data object DH."
@ -1693,7 +1885,7 @@
(setf cleanup nil))
(if cleanup (gpgme-release c-ctx)))))
(defmethod translate-to-foreign (value (type (eql 'gpgme-ctx-t)))
(defun translate-gpgme-ctx-t-to-foreign (value)
;; Allow a pointer to be passed directly for the finalizer to work.
(if (pointerp value) value (slot-value value 'c-ctx)))
@ -1848,11 +2040,11 @@
(setf (slot-value key 'c-key) c-key)
(finalize key (lambda () (gpgme-key-unref c-key))))
(defmethod translate-from-foreign (value (type (eql 'gpgme-key-t)))
(defun translate-gpgme-key-t-from-foreign (value)
(when *debug* (format t "DEBUG: import key: ~A~%" value))
(make-instance 'key :c-key value))
(defmethod translate-to-foreign (value (type (eql 'gpgme-key-t)))
(defun translate-gpgme-key-t-to-foreign (value)
;; Allow a pointer to be passed directly for the finalizer to work.
(if (pointerp value) value (slot-value value 'c-key)))
@ -1867,12 +2059,12 @@
;;; and zero length value (omit?) and human-readable (convert to string).
;;; FIXME: Turn binary data into sequence or vector or what it should be.
;;; FIXME: Turn the whole thing into a hash?
(defmethod translate-from-foreign (value (type (eql 'gpgme-sig-notation-t)))
(defun translate-gpgme-sig-notation-t-from-foreign (value)
(cond
((null-pointer-p value) nil)
(t (with-foreign-slots
((next name value name-len value-len flags bitfield)
value gpgme-sig-notation)
value (:struct gpgme-sig-notation))
(append (list (list
:name name
:value value
@ -1883,12 +2075,12 @@
next)))))
;;; FIXME: Deal nicer with timestamps. bitfield field name?
(defmethod translate-from-foreign (value (type (eql 'gpgme-subkey-t)))
(defun translate-gpgme-subkey-t-from-foreign (value)
(cond
((null-pointer-p value) nil)
(t (with-foreign-slots
((next bitfield pubkey-algo length keyid fpr timestamp expires)
value gpgme-subkey)
value (:struct gpgme-subkey))
(append (list (list
:bitfield bitfield
:pubkey-algo pubkey-algo
@ -1899,13 +2091,13 @@
:expires expires))
next)))))
(defmethod translate-from-foreign (value (type (eql 'gpgme-key-sig-t)))
(defun translate-gpgme-key-sig-t-from-foreign (value)
(cond
((null-pointer-p value) nil)
(t (with-foreign-slots
((next bitfield pubkey-algo keyid timestamp expires status
uid name email comment sig-class)
value gpgme-key-sig)
value (:struct gpgme-key-sig))
(append (list (list
:bitfield bitfield
:pubkey-algo pubkey-algo
@ -1920,12 +2112,12 @@
:sig-class sig-class))
next)))))
(defmethod translate-from-foreign (value (type (eql 'gpgme-user-id-t)))
(defun translate-gpgme-user-id-t-from-foreign (value)
(cond
((null-pointer-p value) nil)
(t (with-foreign-slots
((next bitfield validity uid name email comment signatures)
value gpgme-user-id)
value (:struct gpgme-user-id))
(append (list (list
:bitfield bitfield
:validity validity
@ -1941,7 +2133,7 @@
(with-foreign-slots
((bitfield protocol issuer-serial issuer-name chain-id
owner-trust subkeys uids keylist-mode)
c-key gpgme-key)
c-key (:struct gpgme-key))
(list
:bitfield bitfield
:protocol protocol