[cl-net-snmp-cvs] r48 - in trunk: . asn.1
ctian at common-lisp.net
ctian at common-lisp.net
Fri Sep 21 00:46:45 UTC 2007
Author: ctian
Date: Thu Sep 20 20:46:45 2007
New Revision: 48
Modified:
trunk/asn.1/mib.lisp
trunk/asn.1/oid.lisp
trunk/net-snmp.asd
Log:
MIB Tree Finish
Modified: trunk/asn.1/mib.lisp
==============================================================================
--- trunk/asn.1/mib.lisp (original)
+++ trunk/asn.1/mib.lisp Thu Sep 20 20:46:45 2007
@@ -4,16 +4,53 @@
(in-package :asn.1)
-(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))
+#|
+MIB Tree Structure:
+
+((NIL NIL NIL)
+ (((1) ("iso") #<OBJECT-ID .1(.iso)>)
+ (((3 1) ("org" "iso") #<OBJECT-ID .1.3(.iso.org)>)
+ (((6 3 1) ("dod" "org" "iso") #<OBJECT-ID .1.3.6(.iso.org.dod)>)
+ (((1 6 3 1)
+ ("internet" "dod" "org" "iso")
+ #<OBJECT-ID .1.3.6.1(.iso.org.dod.internet)>)
+ (((1 1 6 3 1)
+ ("directory" "internet" "dod" "org" "iso")
+ #<OBJECT-ID .1.3.6.1.1(.iso.org.dod.internet.directory)>))
+ (((2 1 6 3 1)
+ ("mgmt" "internet" "dod" "org" "iso")
+ #<OBJECT-ID .1.3.6.1.2(.iso.org.dod.internet.mgmt)>))
+ (((3 1 6 3 1)
+ ("experimental" "internet" "dod" "org" "iso")
+ #<OBJECT-ID .1.3.6.1.3(.iso.org.dod.internet.experimental)>))
+ (((4 1 6 3 1)
+ ("private" "internet" "dod" "org" "iso")
+ #<OBJECT-ID .1.3.6.1.4(.iso.org.dod.internet.private)>)
+ (((1 4 1 6 3 1)
+ ("enterprises" "private" "internet" "dod" "org" "iso")
+ #<OBJECT-ID .1.3.6.1.4.1(.iso.org.dod.internet.private.enterprises)>))))))))
+|#
+
+;;; Tree -> ( Tree-Data . Tree-Nodes )
+;;; Tree-Data -> ( Tree-ID Tree-Name Tree-Object )
+;;; Tree-ID -> ( number . Tree-ID )
+;;; Tree-Name -> ( string . Tree-Name )
+;;; Tree-Object -> Object-ID [ ID-List Name-List ]
+
+(defvar *mib-tree* '((() () ())) "MIB Tree") ;; empty tree
+
+(defvar *mib-index* (make-hash-table :test #'string=) "MIB Name Hash")
+
+(defun tree-data (node) (car node))
+(defun tree-nodes (node) (cdr node))
+(defun tree-id (node) (first (tree-data node)))
+(defun tree-name (node) (second (tree-data node)))
+(defun tree-object (node) (third (tree-data node)))
(defun find-node (name &optional (node *mib-tree*))
(declare (type string name))
(labels ((test (n)
- (string= name (tree-name n)))
+ (string= name (car (tree-name n))))
(iter (queue)
(if (null queue) nil
(let ((head (car queue)))
@@ -23,24 +60,50 @@
(if (test node) node
(iter (copy-list (tree-nodes node))))))
-(defun make-node (id name &optional (object nil))
- (declare (type fixnum 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"))))
+(defgeneric insert-node (parent id name))
-(defmethod print-object ((obj object-id) stream)
- (format stream "[~{.~A~}]" (oid-subids obj)))
+(defmethod insert-node ((parent-node list) id name)
+ (if (find-if #'(lambda (x) (= id (car (tree-id x))))
+ (tree-nodes parent-node))
+ (error "Conflict.")
+ (let ((tree-id (cons id (tree-id parent-node)))
+ (tree-name (cons name (tree-name parent-node))))
+ (let ((tree-object (make-instance 'object-id :id tree-id :name tree-name)))
+ (let ((tree-data (list tree-id tree-name tree-object)))
+ (let ((tree-node (cons tree-data nil)))
+ (progn
+ (unless (gethash name *mib-index*)
+ (setf (gethash name *mib-index*) tree-node))
+ (nconc parent-node (cons tree-node nil)))))))))
+
+(defmethod insert-node ((parent-name string) id name)
+ (let ((node (gethash parent-name *mib-index*)))
+ (if node
+ (insert-node node id name)
+ (error "No parent node."))))
+
+(defgeneric tree-node (id &optional node))
+
+(defmethod tree-node ((id integer) &optional (node *mib-tree*))
+ (find-if #'(lambda (x) (= id (car (tree-id x))))
+ (tree-nodes node)))
+
+(defmethod tree-node ((id list) &optional (node *mib-tree*))
+ (if (endp id) (values node t)
+ (let ((next (tree-node (car id) node)))
+ (if next
+ (tree-node (cdr id) next)
+ (values id nil)))))
+(defun resolve (oid-list)
+ )
+
+(defmethod print-object ((obj object-id) stream)
+ (with-slots (rev-ids rev-names) obj
+ (print-unreadable-object (obj stream :type t)
+ (format stream "~{.~A~}(~{.~D~})"
+ (reverse rev-ids)
+ (reverse rev-names)))))
;;; MIB
;;;
@@ -71,9 +134,6 @@
;;; difficult to read. Once this has been tested, this should be
;;; slightly redesigned.
-(defparameter *mib-tree* '(nil nil (1 ("iso")
- (3 ("org")
- (6 ("dod"))))))
(defvar *mib-pathname-base* #p"/usr/share/snmp/mibs/")
@@ -122,3 +182,15 @@
:directory '(:relative "asn.1" "test"))
(asdf:component-pathname (asdf:find-system :net-snmp)))))
+(defun test-initialize ()
+ (progn
+ (insert-node *mib-tree* 1 "iso")
+ (insert-node "iso" 3 "org")
+ (insert-node "org" 6 "dod")
+ (insert-node "dod" 1 "internet")
+ (insert-node "internet" 1 "directory")
+ (insert-node "internet" 2 "mgmt")
+ (insert-node "internet" 3 "experimental")
+ (insert-node "internet" 4 "private")
+ (insert-node "private" 1 "enterprises")
+ *mib-tree*))
Modified: trunk/asn.1/oid.lisp
==============================================================================
--- trunk/asn.1/oid.lisp (original)
+++ trunk/asn.1/oid.lisp Thu Sep 20 20:46:45 2007
@@ -5,21 +5,21 @@
(in-package :asn.1)
(defclass object-id ()
- ((subids :initform nil :type list :reader oid-subids :initarg :id)
+ ((rev-ids :initform nil :type list :initarg :id)
+ (rev-names :initform nil :type list :reader oid-name :initarg :name)
(length :initform 0 :type integer :reader oid-length)))
+(defun oid-id (oid)
+ (declare (type object-id oid))
+ (reverse (slot-value 'rev-ids oid)))
+
(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))
+ (with-slots (rev-ids length) obj
+ (setf length (list-length rev-ids))))
-(defmethod parse-oid ((oids string))
- nil)
+(defmethod make-object-id (ids)
+ (make-instance 'object-id :id (reverse ids)))
;;; Note: defdelim and ddfn are copyed from
;;; Page 228 (Figure 17.4), Paul Graham's /On Lisp/.
@@ -77,7 +77,7 @@
(defun oid-prefix-p (oid1 oid2)
(declare (type object-id oid1 oid2))
- (list-prefix-p (oid-subids oid1) (oid-subids oid2)))
+ (list-prefix-p (oid-id oid1) (oid-id oid2)))
;;; BER Encode & Decode (:object-identifier)
@@ -94,21 +94,22 @@
(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)))))
+ (with-slots (rev-ids length) value
+ (let ((subids (reverse rev-ids)))
+ (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)
@@ -124,7 +125,7 @@
(iter (left-length acc head-p)
(declare (type fixnum left-length)
(type list acc))
- (if (zerop left-length) (nreverse acc)
+ (if (zerop left-length) acc
(multiple-value-bind (n l) (get-number 0 1)
(if head-p
(multiple-value-bind (q r) (floor n 40)
Modified: trunk/net-snmp.asd
==============================================================================
--- trunk/net-snmp.asd (original)
+++ trunk/net-snmp.asd Thu Sep 20 20:46:45 2007
@@ -14,20 +14,21 @@
:net-telent-date ; for time conv
:iolib ; for network
:zebu ; for asn.1 parse
+ :zebu-compiler
)
:components ((:module asn.1 :components ((:file "package")
(:file "syntax" :depends-on ("package"))
(:file "ber" :depends-on ("package"))
(:file "smi" :depends-on ("ber"))
(:file "oid" :depends-on ("syntax" "ber"))
- (:file "mib" :depends-on ("syntax" "oid"))))
- (:file "package")
- (:file "constants" :depends-on ("package"))
- (:file "typedefs" :depends-on ("constants"))
- (:file "snmp-api" :depends-on ("typedefs"))
- (:file "load" :depends-on ("snmp-api"))
- (:file "asn1" :depends-on ("load"))
- (:file "classes" :depends-on ("asn1"))))
+ (:file "mib" :depends-on ("syntax" "oid"))))))
+;; (:file "package")
+;; (:file "constants" :depends-on ("package"))
+;; (:file "typedefs" :depends-on ("constants"))
+;; (:file "snmp-api" :depends-on ("typedefs"))
+;; (:file "load" :depends-on ("snmp-api"))
+;; (:file "asn1" :depends-on ("load"))
+;; (:file "classes" :depends-on ("asn1"))))
(defsystem sabrina
:description "Sabrina - Update server status into database"
More information about the Cl-net-snmp-cvs
mailing list