sasl-scram-rfc.el (sasl-cl-coerce, sasl-cl-mapcar-many, sasl-cl-map, sasl-string...

[gnus] / lisp / sasl-scram-rfc.el

diff --git a/lisp/sasl-scram-rfc.el b/lisp/sasl-scram-rfc.el
index 6c8c009..af571c8 100644 (file)
--- a/lisp/sasl-scram-rfc.el
+++ b/lisp/sasl-scram-rfc.el
@@ -37,7 +37,8 @@
 
 ;;; Code:
 
-(require 'cl-lib)
+(ignore-errors (require 'cl-lib))
+
 (require 'sasl)
 
 ;;; SCRAM-SHA-1
@@ -83,6 +84,87 @@
      "n=" (sasl-client-name client) ","
      "r=" c-nonce)))
 
+(eval-and-compile
+  (declare-function sasl-cl-coerce "sasl-scram-rfc")
+  (declare-function sasl-cl-mapcar-many "sasl-scram-rfc")
+  (if (fboundp 'cl-map)
+      (defalias 'sasl-cl-map 'cl-map)
+    (defun sasl-cl-mapcar-many (func seqs)
+      (if (cdr (cdr seqs))
+         (let* ((res nil)
+                (n (apply 'min (mapcar 'length seqs)))
+                (i 0)
+                (args (copy-sequence seqs))
+                p1 p2)
+           (setq seqs (copy-sequence seqs))
+           (while (< i n)
+             (setq p1 seqs p2 args)
+             (while p1
+               (setcar p2
+                       (if (consp (car p1))
+                           (prog1 (car (car p1))
+                             (setcar p1 (cdr (car p1))))
+                         (aref (car p1) i)))
+               (setq p1 (cdr p1) p2 (cdr p2)))
+             (push (apply func args) res)
+             (setq i (1+ i)))
+           (nreverse res))
+       (let ((res nil)
+             (x (car seqs))
+             (y (nth 1 seqs)))
+         (let ((n (min (length x) (length y)))
+               (i -1))
+           (while (< (setq i (1+ i)) n)
+             (push (funcall func
+                            (if (consp x) (pop x) (aref x i))
+                            (if (consp y) (pop y) (aref y i)))
+                   res)))
+         (nreverse res))))
+
+    (defun sasl-cl-coerce (x type)
+      "Coerce OBJECT to type TYPE.
+TYPE is a Common Lisp type specifier.
+\n(fn OBJECT TYPE)"
+      (cond ((eq type 'list) (if (listp x) x (append x nil)))
+           ((eq type 'vector) (if (vectorp x) x (vconcat x)))
+           ((eq type 'string) (if (stringp x) x (concat x)))
+           ((eq type 'array) (if (arrayp x) x (vconcat x)))
+           ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0))
+           ((and (eq type 'character) (symbolp x))
+            (sasl-cl-coerce (symbol-name x) type))
+           ((eq type 'float) (float x))
+           ;;((cl-typep x type) x)
+           (t (error "Can't coerce %s to type %s" x type))))
+
+    (defun sasl-cl-map (type func seq &rest rest)
+      "Map a FUNCTION across one or more SEQUENCEs, returning a sequence.
+TYPE is the sequence type to return.
+\n(fn TYPE FUNCTION SEQUENCE...)"
+      (let (res y)
+       (if rest
+           (if (or (cdr rest) (nlistp seq) (nlistp (car rest)))
+               (setq res (sasl-cl-mapcar-many func (cons seq rest)))
+             (setq y (car rest))
+             (while (and seq y)
+               (push (funcall func (pop seq) (pop y)) res))
+             (setq res (nreverse res)))
+         (setq res (mapcar func seq)))
+       (and type (sasl-cl-coerce res type)))))
+
+  (if (fboundp 'string-prefix-p)
+      (defalias 'sasl-string-prefix-p 'string-prefix-p)
+    (defun sasl-string-prefix-p (prefix string &optional ignore-case)
+      "Return non-nil if PREFIX is a prefix of STRING.
+If IGNORE-CASE is non-nil, the comparison is done without paying attention
+to case differences."
+      (let ((prefix-length (length prefix)))
+       (cond ((> prefix-length (length string)) nil)
+             (ignore-case
+              (string-equal (downcase prefix)
+                            (downcase (substring string 0 prefix-length))))
+             (t
+              (string-equal prefix (substring string 0 prefix-length))))))))
+
 (defun sasl-scram--client-final-message (hash-fun block-length hash-length client step)
   (unless (string-match
           "^r=\\([^,]+\\),s=\\([^,]+\\),i=\\([0-9]+\\)\\(?:$\\|,\\)"
@@ -99,7 +181,7 @@
         (c-nonce (sasl-client-property client 'c-nonce))
         ;; no channel binding, no authorization id
         (cbind-input "n,,"))
-    (unless (string-prefix-p c-nonce nonce)
+    (unless (sasl-string-prefix-p c-nonce nonce)
       (sasl-error "Invalid nonce from server"))
     (let* ((client-final-message-without-proof
            (concat "c=" (base64-encode-string cbind-input) ","
@@ -119,7 +201,7 @@
                (setq digest (funcall hmac-fun digest password))
                (setq xored (if (null xored)
                                digest
-                             (cl-map 'string 'logxor xored digest))))))
+                             (sasl-cl-map 'string 'logxor xored digest))))))
           (client-key
            (funcall hmac-fun "Client Key" salted-password))
           (stored-key (decode-hex-string (funcall hash-fun client-key)))
@@ -129,7 +211,7 @@
             step-data ","
             client-final-message-without-proof))
           (client-signature (funcall hmac-fun (encode-coding-string auth-message 'utf-8) stored-key))
-          (client-proof (cl-map 'string 'logxor client-key client-signature))
+          (client-proof (sasl-cl-map 'string 'logxor client-key client-signature))
           (client-final-message
            (concat client-final-message-without-proof ","
                    "p=" (base64-encode-string client-proof))))