[cl-net-snmp-cvs] r35 - in trunk/asn.1: . test
ctian at common-lisp.net
ctian at common-lisp.net
Fri Sep 14 09:13:38 UTC 2007
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 , at 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 , at 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
More information about the Cl-net-snmp-cvs
mailing list