net.tls/gpg-error/gpg-error.lisp

   1 ;;;; libgpg-error.lisp
   2
   3 ;;; Copyright (C) 2006 g10 Code GmbH
   4 ;;;
   5 ;;; This file is part of libgpg-error.
   6 ;;;
   7 ;;; libgpg-error is free software; you can redistribute it and/or
   8 ;;; modify it under the terms of the GNU Lesser General Public License
   9 ;;; as published by the Free Software Foundation; either version 2.1 of
  10 ;;; the License, or (at your option) any later version.
  11 ;;;
  12 ;;; libgpg-error is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 ;;; Lesser General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU Lesser General Public
  18 ;;; License along with libgpg-error; if not, write to the Free
  19 ;;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  20 ;;; 02111-1307, USA.
  21
  22 ;;; Set up the library.
  23
  24 (in-package :gpg-error)
  25
  26 (define-foreign-library libgpg-error
  27   (:unix "libgpg-error.so")
  28   (t (:default "libgpg-error")))
  29
  30 (use-foreign-library libgpg-error)
  31
  32 ;;; System dependencies.
  33
  34 (defctype size-t :unsigned-int
  35   "The system size_t type.")
  36
  37 ;;; Error sources.
  38
  39 (defcenum gpg-err-source-t
  40   "The GPG error source type."
  41   (:gpg-err-source-unknown 0)
  42   (:gpg-err-source-gcrypt 1)
  43   (:gpg-err-source-gpg 2)
  44   (:gpg-err-source-gpgsm 3)
  45   (:gpg-err-source-gpgagent 4)
  46   (:gpg-err-source-pinentry 5)
  47   (:gpg-err-source-scd 6)
  48   (:gpg-err-source-gpgme 7)
  49   (:gpg-err-source-keybox 8)
  50   (:gpg-err-source-ksba 9)
  51   (:gpg-err-source-dirmngr 10)
  52   (:gpg-err-source-gsti 11)
  53   (:gpg-err-source-any 31)
  54   (:gpg-err-source-user-1 32)
  55   (:gpg-err-source-user-2 33)
  56   (:gpg-err-source-user-3 34)
  57   (:gpg-err-source-user-4 35))
  58
  59 (defconstant +gpg-err-source-dim+ 256)
  60
  61 ;;; The error code type gpg-err-code-t.
  62
  63 ;;; libgpg-error-codes.lisp is loaded by ASDF.
  64
  65 (defctype gpg-error-t :unsigned-int
  66   "The GPG error code type.")
  67
  68 ;;; Bit mask manipulation constants.
  69
  70 (defconstant +gpg-err-code-mask+ (- +gpg-err-code-dim+ 1))
  71
  72 (defconstant +gpg-err-source-mask+ (- +gpg-err-source-dim+ 1))
  73 (defconstant +gpg-err-source-shift+ 24)
  74
  75 ;;; Constructor and accessor functions.
  76
  77 ;;; If we had in-library versions of our static inlines, we wouldn't
  78 ;;; need to replicate them here.  Oh well.
  79
  80 (defun c-gpg-err-make (source code)
  81   "Construct an error value from an error code and source.
  82    Within a subsystem, use gpg-error instead."
  83   (logior
  84    (ash (logand source +gpg-err-source-mask+)
  85         +gpg-err-source-shift+)
  86    (logand code +gpg-err-code-mask+)))
  87
  88 (defun c-gpg-err-code (err)
  89   "Retrieve the error code from an error value."
  90   (logand err +gpg-err-code-mask+))
  91
  92 (defun c-gpg-err-source (err)
  93   "retrieve the error source from an error value."
  94   (logand (ash err (- +gpg-err-source-shift+))
  95           +gpg-err-source-mask+))
  96
  97 ;;; String functions.
  98
  99 (defcfun ("gpg_strerror" c-gpg-strerror) :string
 100   (err gpg-error-t))
 101
 102 (defcfun ("gpg_strsource" c-gpg-strsource) :string
 103   (err gpg-error-t))
 104
 105 ;;; Mapping of system errors (errno).
 106
 107 (defcfun ("gpg_err_code_from_errno" c-gpg-err-code-from-errno) gpg-err-code-t
 108   (err :int))
 109
 110 (defcfun ("gpg_err_code_to_errno" c-gpg-err-code-to-errno) :int
 111   (code gpg-err-code-t))
 112
 113 (defcfun ("gpg_err_code_from_syserror"
 114           c-gpg-err-code-from-syserror) gpg-err-code-t)
 115
 116 ;;; Self-documenting convenience functions.
 117
 118 ;;; See below.
 119
 120 ;;;
 121 ;;;
 122 ;;; Lispy interface.
 123 ;;;
 124 ;;;
 125
 126 ;;; Low-level support functions.
 127
 128 (defun gpg-err-code-as-value (code-key)
 129   (foreign-enum-value 'gpg-err-code-t code-key))
 130
 131 (defun gpg-err-code-as-key (code)
 132   (foreign-enum-keyword 'gpg-err-code-t code))
 133
 134 (defun gpg-err-source-as-value (source-key)
 135   (foreign-enum-value 'gpg-err-source-t source-key))
 136
 137 (defun gpg-err-source-as-key (source)
 138   (foreign-enum-keyword 'gpg-err-source-t source))
 139
 140 (defun gpg-err-canonicalize (err)
 141   "Canonicalize the error value err."
 142   (gpg-err-make (gpg-err-source err) (gpg-err-code err)))
 143
 144 (defun gpg-err-as-value (err)
 145   "Get the integer representation of the error value ERR."
 146   (let ((error (gpg-err-canonicalize err)))
 147     (c-gpg-err-make (gpg-err-source-as-value (gpg-err-source error))
 148                     (gpg-err-code-as-value (gpg-err-code error)))))
 149
 150 ;;; Constructor and accessor functions.
 151
 152 (defun gpg-err-make (source code)
 153   "Construct an error value from an error code and source.
 154    Within a subsystem, use gpg-error instead."
 155   ;; As an exception to the rule, the function gpg-err-make will use
 156   ;; the error source value as is when provided as integer, instead of
 157   ;; parsing it as an error value.
 158   (list (if (integerp source)
 159             (gpg-err-source-as-key source)
 160             (gpg-err-source source))
 161         (gpg-err-code code)))
 162
 163 (defvar *gpg-err-source-default* :gpg-err-source-unknown
 164   "Define this to specify a default source for gpg-error.")
 165
 166 (defun gpg-error (code)
 167   "Construct an error value from an error code, using the default source."
 168   (gpg-err-make *gpg-err-source-default* code))
 169
 170 (defun gpg-err-code (err)
 171   "Retrieve an error code from the error value ERR."
 172   (cond ((listp err) (second err))
 173         ((keywordp err) err)            ; FIXME
 174         (t (gpg-err-code-as-key (c-gpg-err-code err)))))
 175
 176 (defun gpg-err-source (err)
 177   "Retrieve an error source from the error value ERR."
 178   (cond ((listp err) (first err))
 179         ((keywordp err) err)            ; FIXME
 180         (t (gpg-err-source-as-key (c-gpg-err-source err)))))
 181
 182 ;;; String functions.
 183
 184 (defun gpg-strerror (err)
 185   "Return a string containig a description of the error code."
 186   (c-gpg-strerror (gpg-err-as-value err)))
 187
 188 ;;; FIXME: maybe we should use this as the actual implementation for
 189 ;;; gpg-strerror.
 190
 191 ;; (defcfun ("gpg_strerror_r" c-gpg-strerror-r) :int
 192 ;;   (err gpg-error-t)
 193 ;;   (buf :string)
 194 ;;   (buflen size-t))
 195
 196 ;; (defun gpg-strerror-r (err)
 197 ;;   "Return a string containig a description of the error code."
 198 ;;   (with-foreign-pointer-as-string (errmsg 256 errmsg-size)
 199 ;;     (c-gpg-strerror-r (gpg-err-code-as-value (gpg-err-code err))
 200 ;;                    errmsg errmsg-size)))
 201
 202 (defun gpg-strsource (err)
 203   "Return a string containig a description of the error source."
 204   (c-gpg-strsource (gpg-err-as-value err)))
 205
 206 ;;; Mapping of system errors (errno).
 207
 208 (defun gpg-err-code-from-errno (err)
 209   "Retrieve the error code for the system error.  If the system error
 210    is not mapped, :gpg-err-unknown-errno is returned."
 211   (c-gpg-err-code-from-errno err))
 212
 213 (defun gpg-err-code-to-errno (code)
 214   "Retrieve the system error for the error code.  If this is not a
 215    system error, 0 is returned."
 216   (c-gpg-err-code-to-errno (gpg-err-code code)))
 217
 218 (defun gpg-err-code-from-syserror ()
 219   "Retrieve the error code directly from the system ERRNO.  If the system error
 220    is not mapped, :gpg-err-unknown-errno is returned and
 221    :gpg-err-missing-errno if ERRNO has the value 0."
 222   (c-gpg-err-code-from-syserror))
 223
 224
 225 ;;; Self-documenting convenience functions.
 226
 227 (defun gpg-err-make-from-errno (source err)
 228   (gpg-err-make source (gpg-err-code-from-errno err)))
 229
 230 (defun gpg-error-from-errno (err)
 231   (gpg-error (gpg-err-code-from-errno err)))
 232
 233 (defun gpg-error-from-syserror ()
 234   (gpg-error (gpg-err-code-from-syserror)))
 235
 236 ;;; Error condition
 237
 238 (define-condition gpg-error (error)
 239   ((source :initarg :source :reader gpg-error-source)
 240    (code :initarg :code :reader gpg-error-code))
 241   (:report (lambda (condition stream)
 242              (let ((err (gpg-err-make
 243                          (gpg-error-source condition)
 244                          (gpg-error-code condition))))
 245                (format stream "~A caused error: ~S"
 246                        (gpg-strsource err)
 247                        (gpg-strerror err))))))
 248
 249 (defun signal-gpg-error (err)
 250   (error 'gpg-error
 251          :source (gpg-err-source err)
 252          :code (gpg-err-code err)))