[cl-net-snmp-cvs] r35 - in trunk/asn.1: . test

Author: ctian Date: Fri Sep 14 05:13:38 2007 New Revision: 35

Added: trunk/asn.1/asn.1.zb trunk/asn.1/oid.lisp trunk/asn.1/test/ trunk/asn.1/test/1.asn Modified: trunk/asn.1/ber.lisp trunk/asn.1/mib.lisp trunk/asn.1/stream-test.lisp Log: Add OID encode/decode support

Added: trunk/asn.1/asn.1.zb ============================================================================== --- (empty file) +++ trunk/asn.1/asn.1.zb Fri Sep 14 05:13:38 2007 @@ -0,0 +1,29 @@ +;;;; -*- Mode: Lisp -*- + +(:name "asn.1" + :domain-file "asn.1-domain" + :package "ASN.1" + :grammar "zebu-mg" + :identifier-start-chars + "abcdefghijklmnopqrstuvwxyz" + :identifier-continue-chars + "-abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" + :lex-cats ((BSTRING "'[01]+'B") + (HSTRING "'([A-F0-9]+)'H")) + ) + +;; Domain definition + +Module-Definition := kb-domain: [(-identifier Module-Identifier) + (-body Module-Body)] ; + +;; Productions + +Module-Definition --> + Module-Identifier "DEFINITIONS" "::=" + "BEGIN" Module-Body "END" + { Module-Definition:[(-identifier Module-Identifier) (-body Module-Body)] }; + +Module-Identifier --> Identifier; + +Module-Body --> Identifier;

Modified: trunk/asn.1/ber.lisp ============================================================================== --- trunk/asn.1/ber.lisp (original) +++ trunk/asn.1/ber.lisp Fri Sep 14 05:13:38 2007 @@ -120,8 +120,10 @@

(defgeneric ber-decode-value (stream type length))

-(defmethod ber-decode-value ((stream stream) (type (eql :unknown)) (length integer)) - (declare (type stream stream) (ignore type)) +(defmethod ber-decode-value ((stream stream) (type (eql :unknown)) length) + (declare (type stream stream) + (type integer length) + (ignore type)) (dotimes (i length) (stream-read-byte stream)) nil) @@ -143,8 +145,10 @@ (ber-encode-length l) v))))

-(defmethod ber-decode-value ((stream stream) (type (eql :integer)) (length integer)) - (declare (type stream stream) (ignore type)) +(defmethod ber-decode-value ((stream stream) (type (eql :integer)) length) + (declare (type stream stream) + (type integer length) + (ignore type)) (labels ((iter (i acc) (if (= i length) acc (iter (1+ i) (logior (ash acc 8) (stream-read-byte stream)))))) @@ -157,8 +161,10 @@ (ber-encode-length (length value)) (map 'list #'char-code value)))

-(defmethod ber-decode-value ((stream stream) (type (eql :octet-string)) (length integer)) - (declare (type stream stream) (ignore type)) +(defmethod ber-decode-value ((stream stream) (type (eql :octet-string)) length) + (declare (type stream stream) + (type integer length) + (ignore type)) (let ((str (make-string length))) (map-into str #'(lambda () (code-char (stream-read-byte stream))))))

@@ -171,16 +177,18 @@ (ber-encode-length (length sub-encode)) sub-encode)))

-(defmethod ber-decode-value ((stream stream) (type (eql :sequence)) (length integer)) - (declare (type stream stream) (ignore type)) - (labels ((iter (left acc) - (if (= left 0) +(defmethod ber-decode-value ((stream stream) (type (eql :sequence)) length) + (declare (type stream stream) + (type integer length) + (ignore type)) + (labels ((iter (length-left acc) + (if (= length-left 0) (nreverse acc) (multiple-value-bind (sub-type sub-type-length) (ber-decode-type stream) (multiple-value-bind (sub-length sub-length-length) (ber-decode-length stream) - (iter (- left + (iter (- length-left sub-type-length sub-length-length sub-length) @@ -193,8 +201,10 @@ (nconc (ber-encode-type 0 0 5) (ber-encode-length 0)))

-(defmethod ber-decode-value ((stream stream) (type (eql :null)) (length integer)) - (declare (type stream stream)) +(defmethod ber-decode-value ((stream stream) (type (eql :null)) length) + (declare (type stream stream) + (type integer length) + (ignore type)) (assert (= length 0)) nil)

Modified: trunk/asn.1/mib.lisp ============================================================================== --- trunk/asn.1/mib.lisp (original) +++ trunk/asn.1/mib.lisp Fri Sep 14 05:13:38 2007 @@ -4,3 +4,43 @@

(in-package :asn.1)

+(defparameter *mib-tree* '(nil nil (1 ("iso") + (3 ("org") + (6 ("dod")))))) + +(proclaim '(inline tree-id tree-name tree-object tree-nodes)) +(defun tree-id (node) (car node)) +(defun tree-name (node) (caadr node)) +(defun tree-object (node) (cdadr node)) +(defun tree-nodes (node) (cddr node)) + +(defun find-node (name &optional (node *mib-tree*)) + (declare (type string name)) + (labels ((test (n) + (string= name (tree-name n))) + (iter (queue) + (if (null queue) nil + (let ((head (car queue))) + (if (test head) head + (iter (cdr (append queue + (copy-list (tree-nodes (car queue))))))))))) + (if (test node) node + (iter (copy-list (tree-nodes node)))))) + +(defun make-node (id name &optional (object nil)) + (declare (type integer id) + (type string name)) + (list id (cons name object))) + +(defun insert-node (node parent-name) + (let ((parent-node (find-node parent-name))) + (if parent-node + (if (find-if #'(lambda (x) (= (tree-id node) + (tree-id x))) + (tree-nodes parent-node)) + (error "id conflict") + (nconc parent-node (list node))) + (error "cannot find parent")))) + +(defmethod print-object ((obj object-id) stream) + (format stream "[~{.~A~}]" (oid-subids obj)))

Added: trunk/asn.1/oid.lisp ============================================================================== --- (empty file) +++ trunk/asn.1/oid.lisp Fri Sep 14 05:13:38 2007 @@ -0,0 +1,135 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Object ID Base Support ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(in-package :asn.1) + +(defclass object-id () + ((subids :initform nil :type list :reader oid-subids :initarg :id) + (length :initform 0 :type integer :reader oid-length))) + +(defmethod shared-initialize :after ((obj object-id) slot-names &rest initargs) + (declare (ignore slot-names initargs)) + (with-slots (subids length) obj + (setf length (list-length subids)))) + +(defgeneric parse-oid (oids)) + +(defmethod parse-oid ((oids list)) + (make-instance 'object-id :id oids)) + +(defmethod parse-oid ((oids string)) + nil) + +;;; Note: defdelim and ddfn are copyed from +;;; Page 228 (Figure 17.4), Paul Graham's /On Lisp/. + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro defdelim (left right parms &body body) + `(ddfn ,left ,right #'(lambda ,parms ,@body))) + + (let ((rpar (get-macro-character #)))) + (defun ddfn (left right fn) + (set-macro-character right rpar) + (set-dispatch-macro-character ## left + #'(lambda (stream char-1 char-2) + (declare (ignore char-1 char-2)) + (apply fn + (read-delimited-list right stream t)))))) + + ;;; Object ID Reader Macro #{...} + (defdelim #{ #} (&rest args) + `(parse-oid (list ,@args)))) + +;;; Note: oid-component, oid-component-length, list-prefix-p, oid-list->=, +;;; oid-list-< and oid-prefix-p are copyed from +;;; the Lisp-SNMP Project: http://www.cliki.net/Lisp-SNMP + +(deftype oid-component () '(unsigned-byte 29)) +(deftype oid-component-length () '(integer 0 4)) + +(defun list-prefix-p (list1 list2) + (if (endp list1) + (values t list2) + (let ((f1 (first list1)) (f2 (first list2))) + (declare (type oid-component f1 f2)) + (and (eql f1 f2) (list-prefix-p (rest list1) (rest list2)))))) + +(defun oid-list->= (oid1 oid2) + (declare (type list oid1 oid2)) + (or (endp oid2) + (and (not (endp oid1)) + (let ((f1 (first oid1)) (f2 (first oid2))) + (declare (type oid-component f1 f2)) + (or (> f1 f2) + (and (= f1 f2) + (oid-list->= (rest oid1) (rest oid2)))))))) + +(defun oid-list-< (oid1 oid2) + (declare (type list oid1 oid2)) + (and (not (endp oid2)) + (or (endp oid1) + (let ((f1 (first oid1)) (f2 (first oid2))) + (declare (type oid-component f1 f2)) + (or (< f1 f2) + (and (= f1 f2) + (oid-list-< (rest oid1) (rest oid2)))))))) + +(defun oid-prefix-p (oid1 oid2) + (declare (type object-id oid1 oid2)) + (list-prefix-p (oid-subids oid1) (oid-subids oid2))) + +;;; BER Encode & Decode (:object-identifier) + +(defmethod ber-encode ((value object-id)) + (labels ((number-get (n) + (if (= n 0) (values (list 0) 1) + (number-split n 0 nil 0))) + (number-split (n p acc l) + (if (= n 0) (values acc l) + (multiple-value-bind (q r) (floor n 128) + (number-split q 1 (cons (logior (ash p 7) r) acc) (1+ l))))) + (iter (oids acc len) + (if (endp oids) + (values acc len) + (multiple-value-bind (sub-oid sub-length) (number-get (car oids)) + (iter (cdr oids) (nconc acc sub-oid) (+ len sub-length)))))) + (with-slots (subids length) value + (multiple-value-bind (v l) + (case length + (0 (values nil 0)) + (1 (number-split (* (first subids) 40) 0 nil 0)) + (2 (number-split (+ (* (first subids) 40) + (second subids)) 0 nil 0)) + (otherwise (apply #'iter + (cddr subids) + (multiple-value-list + (number-split (+ (* (first subids) 40) + (second subids)) 0 nil 0))))) + (nconc (ber-encode-type 0 0 6) + (ber-encode-length l) + v))))) + +(defmethod ber-decode-value ((stream stream) (type (eql :object-identifier)) length) + (declare (type stream stream) + (type integer length) + (ignore type)) + (if (= length 0) #{} + (labels ((get-number (acc len) + (let* ((byte (stream-read-byte stream)) + (val (logior (ash acc 7) (logand byte 127)))) + (if (< byte 128) (values val len) + (get-number val (1+ len))))) + (iter (left-length acc head-p) + (declare (type integer left-length) + (type list acc)) + (if (= left-length 0) (nreverse acc) + (multiple-value-bind (n l) (get-number 0 1) + (if head-p + (multiple-value-bind (q r) (floor n 40) + (iter (- left-length l) (cons r (cons q acc)) nil)) + (iter (- left-length l) (cons n acc) nil)))))) + (make-instance 'object-id :id (iter length nil t))))) + +(eval-when (:load-toplevel :execute) + (install-asn.1-type :object-identifier 0 0 6))

Modified: trunk/asn.1/stream-test.lisp ============================================================================== --- trunk/asn.1/stream-test.lisp (original) +++ trunk/asn.1/stream-test.lisp Fri Sep 14 05:13:38 2007 @@ -15,3 +15,10 @@ (let ((byte (elt (ber-sequence instance) (ber-position instance)))) (incf (ber-position instance)) byte))) + +(defun ber-test (x) + (let ((code (ber-encode x))) + (format t "~A -> ~A~%~{~8,'0B ~}~%~{~D ~}~%" + x (ber-decode (make-instance 'ber-stream :seq code)) + code code) + x))

Added: trunk/asn.1/test/1.asn ============================================================================== --- (empty file) +++ trunk/asn.1/test/1.asn Fri Sep 14 05:13:38 2007 @@ -0,0 +1,4 @@ +aAAA DEFINITIONS ::= +BEGIN + bBBB +END