[cl-net-snmp-cvs] r33 - in trunk: . asn.1
ctian at common-lisp.net
ctian at common-lisp.net
Thu Sep 13 10:42:21 UTC 2007
Author: ctian
Date: Thu Sep 13 06:42:18 2007
New Revision: 33
Added:
trunk/asn.1/
trunk/asn.1/ber.lisp
trunk/asn.1/mib.lisp
trunk/asn.1/package.lisp
trunk/asn.1/stream-test.lisp
Modified:
trunk/net-snmp-dff.lisp
trunk/net-snmp.asd
Log:
Add pure lisp ASN.1 support
Added: trunk/asn.1/ber.lisp
==============================================================================
--- (empty file)
+++ trunk/asn.1/ber.lisp Thu Sep 13 06:42:18 2007
@@ -0,0 +1,205 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; BER Base Support ;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(in-package :asn.1)
+
+(let ((dispatch-table
+ (make-hash-table :test #'equal)))
+ (defun get-asn.1-type (class p/c tags)
+ (gethash (list class p/c tags) dispatch-table :unknown))
+ (defun install-asn.1-type (type class p/c tags)
+ (setf (gethash (list class p/c tags) dispatch-table) type)))
+
+;;;; 8 7 6 5 4 3 2 1
+;;;; +-------+-----+-----------+
+;;;; | class | P/C | tags |
+;;;; +-------+-----+-----------+
+;;;; ^ ^
+;;;; 00=universal 0=primitive
+;;;; 01=app. 1=construct
+;;;; 10=context.
+;;;; 11=private
+;;;; (type domain (tag = 0-30)
+
+;;;; |<-------head byte------->| |<---------------other bytes---------------->|
+;;;; 1st byte last byte
+;;;; |<------>| |<------>|
+;;;; 8 7 6 5 4 3 2 1
+;;;; +-------+-----+-----------+ +---+----+ +---+----+ +---+----+ +---+----+
+;;;; | class | P/C | 1 1 1 1 1 | | 1 |////| | 1 |////|... | 1 |////| | 0 |////|
+;;;; +-------+-----+-----------+ +---+----+ +---+----+ +---+----+ +---+----+
+;;;; +----+ +----+ +----+ +----+
+;;;; tags = |////| + |////|... + |////| + |////|
+;;;; +----+ +----+ +----+ +----+
+;;;; (type domain (tag >= 31)
+
+(defun ber-encode-type (class p/c tags)
+ "Encode BER Type Domain"
+ (declare (type (integer 0 3) class)
+ (type (integer 0 1) p/c)
+ (type (integer 0) tags))
+ (assert (and (<= 0 class 3) (<= 0 p/c 1) (<= 0 tags)))
+ (labels ((iter (n p acc)
+ (if (= n 0) acc
+ (multiple-value-bind (q r) (floor n 128)
+ (iter q 1 (cons (logior (ash p 7) r) acc))))))
+ (if (< tags 31)
+ (list (logior (ash class 6) (ash p/c 5) tags))
+ (cons (logior (ash class 6) (ash p/c 5) 31)
+ (iter tags 0 nil)))))
+
+(defun ber-decode-type (stream)
+ "Decode BER Type Domain"
+ (declare (type stream stream))
+ (let ((byte (stream-read-byte stream))
+ (type-length 1))
+ (let ((class (ldb (byte 2 6) byte))
+ (p/c (ldb (byte 1 5) byte))
+ (tags (ldb (byte 5 0) byte)))
+ (when (= tags 31)
+ (setf tags (labels ((iter (acc)
+ (setf byte (stream-read-byte stream))
+ (incf type-length)
+ (let ((temp (logior (ash acc 7) (ldb (byte 7 0) byte))))
+ (if (= (ldb (byte 1 7) byte) 1) (iter temp) temp))))
+ (iter 0))))
+ (values (get-asn.1-type class p/c tags)
+ type-length))))
+
+;;;; 8 7 6 5 4 3 2 1
+;;;; +---+-+-+-+-+-+-+-+
+;;;; | 0 |
+;;;; +---+-+-+-+-+-+-+-+
+;;;; (short form: Length = 0-127 octets)
+
+;;;; 8 7 6 5 4 3 2 1 8 7 6 5 4 3 2 1 8 7 6 5 4 3 2 1
+;;;; +---+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+
+;;;; | 1 | | | ... | |
+;;;; +---+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+
+;;;; |<--number--->| ^ ^
+;;;; of other byte 1: MSB byte n: MLB
+;;;; bytes
+;;;; (0<n<127)
+;;;; (long form: Length = 0-(2^1008-1) octets)
+
+(defun ber-encode-length (length)
+ "Encode BER Length Domain"
+ (declare (type (integer 0) length))
+ (assert (<= 0 length (1- (expt 2 1008))))
+ (labels ((iter (n acc l)
+ (if (= n 0) (cons (mod (logior 128 l) 256) acc)
+ (multiple-value-bind (q r) (floor n 256)
+ (iter q (cons r acc) (1+ l))))))
+ (if (< length 128) (list length)
+ (iter length nil 0))))
+
+(defun ber-decode-length (stream)
+ "Decode BER Length Domain"
+ (declare (type stream stream))
+ (let ((byte (stream-read-byte stream))
+ (length-length 1))
+ (let ((flag (ldb (byte 1 7) byte))
+ (l-or-n (ldb (byte 7 0) byte)))
+ (let ((res (if (= flag 0) l-or-n
+ (let ((acc 0))
+ (dotimes (i l-or-n)
+ (setf acc (logior (ash acc 8)
+ (stream-read-byte stream)))
+ (incf length-length)
+ acc)))))
+ (values res length-length)))))
+
+(defgeneric ber-encode (value))
+
+(defun ber-decode (stream)
+ (declare (type stream stream))
+ (let ((type (ber-decode-type stream))
+ (length (ber-decode-length stream)))
+ (ber-decode-value stream type length)))
+
+(defgeneric ber-decode-value (stream type length))
+
+(defmethod ber-decode-value ((stream stream) (type (eql :unknown)) (length integer))
+ (declare (type stream stream) (ignore type))
+ (dotimes (i length)
+ (stream-read-byte stream))
+ nil)
+
+;;;;;;;;;;;;;;;;;;;;;;;
+;;;; Special Types ;;;;
+;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Integer (:integer)
+
+(defmethod ber-encode ((value integer))
+ (assert (<= 0 value))
+ (labels ((iter (n acc l)
+ (if (= n 0) (values acc l)
+ (multiple-value-bind (q r) (floor n 256)
+ (iter q (cons r acc) (1+ l))))))
+ (multiple-value-bind (v l) (iter value nil 0)
+ (nconc (ber-encode-type 0 0 2)
+ (ber-encode-length l)
+ v))))
+
+(defmethod ber-decode-value ((stream stream) (type (eql :integer)) (length integer))
+ (declare (type stream stream) (ignore type))
+ (labels ((iter (i acc)
+ (if (= i length) acc
+ (iter (1+ i) (logior (ash acc 8) (stream-read-byte stream))))))
+ (iter 0 0)))
+
+;;; OCTET STRING (:octet-string)
+
+(defmethod ber-encode ((value simple-base-string))
+ (nconc (ber-encode-type 0 0 4)
+ (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))
+ (let ((str (make-string length)))
+ (map-into str #'(lambda () (code-char (stream-read-byte stream))))))
+
+;;; SEQUENCE (:sequence)
+
+(defmethod ber-encode ((value sequence))
+ (let ((sub-encode (apply #'nconc
+ (map 'list #'ber-encode value))))
+ (nconc (ber-encode-type 0 1 16)
+ (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)
+ (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
+ sub-type-length
+ sub-length-length
+ sub-length)
+ (cons (ber-decode-value stream sub-type sub-length) acc)))))))
+ (iter length nil)))
+
+;;; NULL (:null)
+(defmethod ber-encode ((value (eql nil)))
+ (declare (ignore value))
+ (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))
+ (assert (= length 0))
+ nil)
+
+(eval-when (:load-toplevel :execute)
+ (install-asn.1-type :integer 0 0 2)
+ (install-asn.1-type :octet-string 0 0 4)
+ (install-asn.1-type :null 0 0 5)
+ (install-asn.1-type :sequence 0 1 16))
Added: trunk/asn.1/mib.lisp
==============================================================================
--- (empty file)
+++ trunk/asn.1/mib.lisp Thu Sep 13 06:42:18 2007
@@ -0,0 +1,6 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; MIB Base Support ;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(in-package :asn.1)
+
Added: trunk/asn.1/package.lisp
==============================================================================
--- (empty file)
+++ trunk/asn.1/package.lisp Thu Sep 13 06:42:18 2007
@@ -0,0 +1,7 @@
+(in-package :cl-user)
+
+(defpackage :asn.1
+ (:use :common-lisp
+ #+lispworks :stream))
+
+(in-package :asn.1)
Added: trunk/asn.1/stream-test.lisp
==============================================================================
--- (empty file)
+++ trunk/asn.1/stream-test.lisp Thu Sep 13 06:42:18 2007
@@ -0,0 +1,17 @@
+(in-package :asn.1)
+
+(defclass ber-stream (fundamental-input-stream)
+ ((sequence :type sequence :initarg :seq :reader ber-sequence)
+ (length :type integer :accessor ber-length)
+ (position :type integer :initform 0 :accessor ber-position)))
+
+(defmethod shared-initialize :after ((instance ber-stream) slot-names &rest initargs)
+ (declare (ignore slot-names initargs))
+ (setf (ber-length instance) (length (ber-sequence instance))))
+
+(defmethod stream-read-byte ((instance ber-stream))
+ (if (= (ber-position instance) (ber-length instance))
+ :eof
+ (let ((byte (elt (ber-sequence instance) (ber-position instance))))
+ (incf (ber-position instance))
+ byte)))
Modified: trunk/net-snmp-dff.lisp
==============================================================================
--- trunk/net-snmp-dff.lisp (original)
+++ trunk/net-snmp-dff.lisp Thu Sep 13 06:42:18 2007
@@ -267,4 +267,4 @@
:result-type
:int
:language
- :ansi-c)
\ No newline at end of file
+ :ansi-c)
Modified: trunk/net-snmp.asd
==============================================================================
--- trunk/net-snmp.asd (original)
+++ trunk/net-snmp.asd Thu Sep 13 06:42:18 2007
@@ -2,18 +2,20 @@
(in-package :cl-user)
-(defpackage :net-snmp-system
- (:use :cl :asdf))
-
+(defpackage net-snmp-system (:use :common-lisp :asdf))
(in-package :net-snmp-system)
(defsystem net-snmp
:description "Common Lisp interface for Net-SNMP"
:version "0.6"
:author "Chun Tian (binghe) <binghe.lisp at gmail.com>"
- :depends-on (:cffi)
- :components ((:file "package")
- (:file "constants" :depends-on ("package"))
+ :depends-on (:cffi
+ :ironclad
+ :net-telent-date)
+ :components ((:module asn.1 :components ((:file "package")
+ (:file "ber" :depends-on ("package"))))
+ (:file "package")
+ (:file "constants" :depends-on ("package"))
(:file "typedefs" :depends-on ("constants"))
(:file "snmp-api" :depends-on ("typedefs"))
(:file "load" :depends-on ("snmp-api"))
@@ -26,7 +28,6 @@
:version "0.1"
:author "Chun Tian (binghe) <binghe.lisp at gmail.com>"
:depends-on (:net-snmp
- :net-telent-date
:hunchentoot
:clsql-postgresql)
:components ((:file "sabrina")
More information about the Cl-net-snmp-cvs
mailing list