sbcl stuff

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/condition.lisp

@@ -0,0 +1,237 @@
+;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: USOCKET -*-
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+;; Condition signalled by operations with unsupported arguments
+;; For trivial-sockets compatibility.
+
+(define-condition insufficient-implementation (error)
+  ((feature :initarg :feature :reader feature)
+   (context :initarg :context :reader context
+    :documentation "String designator of the public API function which
+the feature belongs to."))
+  (:documentation "The ancestor of all errors usocket may generate
+because of insufficient support from the underlying implementation
+with respect to the arguments given to `function'.
+
+One call may signal several errors, if the caller allows processing
+to continue.
+"))
+
+(define-condition unsupported (insufficient-implementation)
+  ((minimum :initarg :minimum :reader minimum
+            :documentation "Indicates the minimal version of the
+implementation required to support the requested feature."))
+  (:report (lambda (c stream)
+	     (format stream "~A in ~A is unsupported."
+		     (feature c) (context c))
+	     (when (minimum c)
+	       (format stream " Minimum version (~A) is required."
+		       (minimum c)))))
+  (:documentation "Signalled when the underlying implementation
+doesn't allow supporting the requested feature.
+
+When you see this error, go bug your vendor/implementation developer!"))
+
+(define-condition unimplemented (insufficient-implementation)
+  ()
+  (:report (lambda (c stream)
+	     (format stream "~A in ~A is unimplemented."
+		     (feature c) (context c))))
+  (:documentation "Signalled if a certain feature might be implemented,
+based on the features of the underlying implementation, but hasn't
+been implemented yet."))
+
+;; Conditions raised by sockets operations
+
+(define-condition socket-condition (condition)
+  ((socket :initarg :socket
+           :accessor usocket-socket))
+  ;;###FIXME: no slots (yet); should at least be the affected usocket...
+  (:documentation "Parent condition for all socket related conditions."))
+
+(define-condition socket-error (socket-condition error)
+  () ;; no slots (yet)
+  (:documentation "Parent error for all socket related errors"))
+
+(define-condition ns-condition (condition)
+  ((host-or-ip :initarg :host-or-ip
+               :accessor host-or-ip))
+  (:documentation "Parent condition for all name resolution conditions."))
+
+(define-condition ns-error (ns-condition error)
+  ()
+  (:documentation "Parent error for all name resolution errors."))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun define-usocket-condition-class (class &rest parents)
+    `(progn
+       (define-condition ,class ,parents ())
+       (eval-when (:load-toplevel :execute)
+         (export ',class)))))
+
+(defmacro define-usocket-condition-classes (class-list parents)
+  `(progn ,@(mapcar #'(lambda (x)
+                        (apply #'define-usocket-condition-class
+                               x parents))
+                    class-list)))
+
+;; Mass define and export our conditions
+(define-usocket-condition-classes
+  (interrupted-condition)
+  (socket-condition))
+
+(define-condition unknown-condition (socket-condition)
+  ((real-condition :initarg :real-condition
+                   :accessor usocket-real-condition))
+  (:documentation "Condition raised when there's no other - more applicable -
+condition available."))
+
+
+;; Mass define and export our errors
+(define-usocket-condition-classes
+  (address-in-use-error
+   address-not-available-error
+   bad-file-descriptor-error
+   connection-refused-error
+   connection-aborted-error
+   connection-reset-error
+   invalid-argument-error
+   no-buffers-error
+   operation-not-supported-error
+   operation-not-permitted-error
+   protocol-not-supported-error
+   socket-type-not-supported-error
+   network-unreachable-error
+   network-down-error
+   network-reset-error
+   host-down-error
+   host-unreachable-error
+   shutdown-error
+   timeout-error
+   deadline-timeout-error
+   invalid-socket-error
+   invalid-socket-stream-error)
+  (socket-error))
+
+(define-condition unknown-error (socket-error)
+  ((real-error :initarg :real-error
+               :accessor usocket-real-error
+               :initform nil)
+   (errno      :initarg :errno
+               :reader usocket-errno
+               :initform 0))
+  (:report (lambda (c stream)
+             (typecase c
+               (simple-condition
+                (format stream
+                        (simple-condition-format-control (usocket-real-error c))
+                        (simple-condition-format-arguments (usocket-real-error c))))
+               (otherwise
+                (format stream "The condition ~A occurred with errno: ~D."
+                        (usocket-real-error c)
+                        (usocket-errno c))))))
+  (:documentation "Error raised when there's no other - more applicable -
+error available."))
+
+(define-usocket-condition-classes
+  (ns-try-again-condition)
+  (ns-condition))
+
+(define-condition ns-unknown-condition (ns-condition)
+  ((real-condition :initarg :real-condition
+                   :accessor ns-real-condition
+                   :initform nil))
+  (:documentation "Condition raised when there's no other - more applicable -
+condition available."))
+
+(define-usocket-condition-classes
+  ;; the no-data error code in the Unix 98 api
+  ;; isn't really an error: there's just no data to return.
+  ;; with lisp, we just return NIL (indicating no data) instead of
+  ;; raising an exception...
+  (ns-host-not-found-error
+   ns-no-recovery-error)
+  (ns-error))
+
+(define-condition ns-unknown-error (ns-error)
+  ((real-error :initarg :real-error
+               :accessor ns-real-error
+               :initform nil))
+  (:report (lambda (c stream)
+             (typecase c
+               (simple-condition
+                (format stream
+                        (simple-condition-format-control (usocket-real-error c))
+                        (simple-condition-format-arguments (usocket-real-error c))))
+               (otherwise
+                (format stream "The condition ~A occurred." (usocket-real-error c))))))
+  (:documentation "Error raised when there's no other - more applicable -
+error available."))
+
+(defmacro with-mapped-conditions ((&optional socket host-or-ip) &body body)
+  `(handler-bind ((condition
+                   #'(lambda (c) (handle-condition c ,socket ,host-or-ip))))
+     ,@body))
+
+(defparameter +unix-errno-condition-map+
+  `(((11) . ns-try-again-condition) ;; EAGAIN
+    ((35) . ns-try-again-condition) ;; EDEADLCK
+    ((4) . interrupted-condition))) ;; EINTR
+
+(defparameter +unix-errno-error-map+
+  ;;### the first column is for non-(linux or srv4) systems
+  ;; the second for linux
+  ;; the third for srv4
+  ;;###FIXME: How do I determine on which Unix we're running
+  ;;          (at least in clisp and sbcl; I know about cmucl...)
+  ;; The table below works under the assumption we'll *only* see
+  ;; socket associated errors...
+  `(((48 98) . address-in-use-error)
+    ((49 99) . address-not-available-error)
+    ((9) . bad-file-descriptor-error)
+    ((61 111) . connection-refused-error)
+    ((54 104) . connection-reset-error)
+    ((53 103) . connection-aborted-error)
+    ((22) . invalid-argument-error)
+    ((55 105) . no-buffers-error)
+    ((12) . out-of-memory-error)
+    ((45 95) . operation-not-supported-error)
+    ((1) . operation-not-permitted-error)
+    ((43 92) . protocol-not-supported-error)
+    ((44 93) . socket-type-not-supported-error)
+    ((51 101) . network-unreachable-error)
+    ((50 100) . network-down-error)
+    ((52 102) . network-reset-error)
+    ((58 108) . already-shutdown-error)
+    ((60 110) . timeout-error)
+    ((64 112) . host-down-error)
+    ((65 113) . host-unreachable-error)))
+
+(defun map-errno-condition (errno)
+  (cdr (assoc errno +unix-errno-error-map+ :test #'member)))
+
+(defun map-errno-error (errno)
+  (cdr (assoc errno +unix-errno-error-map+ :test #'member)))
+
+(defparameter +unix-ns-error-map+
+  `((1 . ns-host-not-found-error)
+    (2 . ns-try-again-condition)
+    (3 . ns-no-recovery-error)))
+
+(defmacro unsupported (feature context &key minimum)
+  `(cerror "Ignore it and continue" 'unsupported
+	   :feature ,feature
+	   :context ,context
+	   :minimum ,minimum))
+
+(defmacro unimplemented (feature context)
+  `(signal 'unimplemented :feature ,feature :context ,context))
+
+;;; People may want to ignore all unsupported warnings, here it is.
+(defmacro ignore-unsupported-warnings (&body body)
+  `(handler-bind ((unsupported
+                   #'(lambda (c)
+                       (declare (ignore c)) (continue))))
+     (progn ,@body)))