From mb at bese.it Fri Oct 1 15:08:53 2004 From: mb at bese.it (marco) Date: Fri, 01 Oct 2004 17:08:53 +0200 Subject: [Small-cl-src] small mop compatability layer Message-ID: ;;;; -*- lisp -*- (defpackage :it.bese.arnesi.mopp (:nicknames :mopp) (:documentation "A MOP compatabilitly layer. This package wraps the various similar but slightly different MOP APIs. All the MOP symbols are exported (even those which are normally exported from the common-lisp package) though not all maybe be properly defined on all lisps. The name of library is a ancronym for "the Meta Object Protocol Package". Notes: The mopp package also exports the function SLOT-DEFINITION-DOCUMENTATION which while not strictly part of the MOP really should be and is implementened on most systems. Lispworks - (tested only lightly) Implement a eql-specializer class and define a version of method-specializers built upon clos:method-specializers which returns them. This package is part of the arnesi utility library but has been written so that this single file can be included in other applications without requiring the rest of the arnesi library.") (:use) (:export ;; classes #:standard-object #:funcallable-standard-object #:metaobject #:generic-function #:standard-generic-function #:method #:standard-method #:standard-accessor-method #:standard-reader-method #:standard-writer-method #:method-combination #:slot-definition #:direct-slot-definition #:effective-slot-definition #:standard-slot-definition #:standard-direct-slot-definition #:standard-effective-slot-definition #:specializer #:eql-specializer #:class #:built-in-class #:forward-referenced-class #:standard-class #:funcallable-standard-class ;; Taken from the MOP dictionary #:accessor-method-slot-definition #:add-dependent #:add-direct-method #:add-direct-subclass #:add-method #:allocate-instance #:class-default-initargs #:class-direct-default-initargs #:class-direct-slots #:class-direct-subclasses #:class-direct-superclasses #:class-finalized-p #:class-name #:class-precedence-list #:class-prototype #:class-slots #:compute-applicable-methods #:compute-applicable-methods-using-classes #:compute-class-precedence-list #:compute-default-initargs #:compute-discriminating-function #:compute-effective-method #:compute-effective-slot-definition #:compute-slots #:direct-slot-definition-class #:effective-slot-definition-class #:ensure-class-using-class #:ensure-generic-function #:ensure-generic-function-using-class #:eql-specializer-object #:extract-lambda-list #:extract-specializer-names #:finalize-inheritance #:find-method-combination #:funcallable-standard-instance-access #:generic-function-argument-precedence-order #:generic-function-declarations #:generic-function-lambda-list #:generic-function-method-class #:generic-function-method-combination #:generic-function-methods #:generic-function-name #:intern-eql-specializer #:make-instance #:make-method-lambda #:map-dependents #:method-function #:method-generic-function #:method-lambda-list #:method-specializers #:method-qualifiers #:reader-method-class #:remove-dependent #:remove-direct-method #:remove-direct-subclass #:remove-method #:set-funcallable-instance-function #:slot-boundp-using-class #:slot-definition-allocation #:slot-definition-documentation #:slot-definition-initargs #:slot-definition-initform #:slot-definition-initfunction #:slot-definition-location #:slot-definition-name #:slot-definition-readers #:slot-definition-writers #:slot-definition-type #:slot-makunbound-using-class #:slot-value-using-class #:specializer-direct-generic-functions #:specializer-direct-methods #:standard-instance-access #:update-dependent #:validate-superclass #:writer-method-class)) (defpackage :it.bese.arnesi.mopp%internals (:use :common-lisp)) (in-package :it.bese.arnesi.mopp%internals) (defgeneric provide-mopp-symbol (symbol implementation) (:documentation "Provide the implementation of the MOP symbol SYMBOL. SYMBOL - One of the external symbols of the package it.bese.arnesi.mopp IMPLEMENTATION - A keyword indetifying the implementation, one of: :OPENMCL, :SBCL, :CMU, :LISPWORKS. Do \"something\" such that the external symbol SYMBOL in the mopp package provides the sematics for the like named symbol in the MOP. Methods defined on this generic function are free to destructivly modify SYMBOL (and the mopp package) as long as when the method terminates there is a symbol with the same name as SYMBOL exported form the package mopp. Methods must return a true value if they have successfully provided SYMBOL and nil otherwise.")) (defun import-to-mopp (symbol) (let ((sym (find-symbol (string symbol) :it.bese.arnesi.mopp))) (when sym (unexport sym :it.bese.arnesi.mopp) (unintern sym :it.bese.arnesi.mopp))) (import symbol :it.bese.arnesi.mopp) (export symbol :it.bese.arnesi.mopp) t) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; OpenMCL (defmethod provide-mopp-symbol ((symbol symbol) (implementation (eql :openmcl))) "Provide MOP symbols for OpenMCL. All of OpenMCL's MOP is defined in the CCL package." (when (find-symbol (string symbol) :ccl) (import-to-mopp (find-symbol (string symbol) :ccl)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; SBCL (defmethod provide-mopp-symbol ((symbol symbol) (implementation (eql :sbcl))) (when (find-symbol (string symbol) :sb-pcl) (import-to-mopp (find-symbol (string symbol) :sb-pcl)))) (defmethod provide-mopp-symbol ((symbol (eql 'mopp:slot-definition-documentation)) (implementation (eql :sbcl))) "Provide SLOT-DEFINITION-DOCUMENTATION for SBCL. On SBCL SLOT-DEFINITION-DOCUMENTATION is just a call to sb-pcl:documentation." t) #+sbcl (defun mopp:slot-definition-documentation (slot) (sb-pcl::documentation slot t)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; CMUCL (defmethod provide-mopp-symbol ((symbol symbol) (implementation (eql :cmu))) (when (find-symbol (string symbol) :pcl) (import-to-mopp (find-symbol (string symbol) :pcl)))) (defmethod provide-mopp-symbol ((symbol (eql 'mopp:slot-definition-documentation)) (implementation (eql :cmu))) "Provide SLOT-DEFINITION-DOCUMENTATION on CMUCL. Like SBCL SLOT-DEFINITION-DOCUMENTATION on CMUCL is just a call to documentation." t) #+cmu (defun mopp:slot-definition-documentation (slot) (documentation slot t)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Lispworks (defmethod provide-mopp-symbol ((symbol symbol) (implementation (eql :lispworks))) (when (find-symbol (string symbol) :clos) (import-to-mopp (find-symbol (string symbol) :clos)))) (defmethod provide-mopp-symbol ((symbol (eql 'mopp:eql-specializer)) (implementation (eql :lispworks))) t) (defmethod provide-mopp-symbol ((symbol (eql 'mopp:eql-specializer-object)) (implementation (eql :lispworks))) t) (defmethod provide-mopp-symbol ((symbol (eql 'mopp:method-specializers)) (implementation (eql :lispworks))) "We can not simply export CLOS:METHOD-SPECIALIZERS as we have to insert mopp:eql-specializers" t) #+lispworks (defclass mopp:eql-specializer () ((object :accessor mopp::eql-specializer-object :initarg :object)) (:documentation "Wrapper class representing eql-specializers. Lispworks does not implement an eql-specializer class but simply returns lists form method-specializers, this class (along with a wrapper for clos:method-specializers) hides this detail.")) #+lispworks (defun mopp:method-specializers (method) "More MOP-y implementation of clos:method-specializers. For every returned value of clos:method-specializers of the form `(eql ,OBJECT) this function returns a mopp:eql-specializer object wrapping OBJECT." (mapcar (lambda (spec) (typecase spec (cons (make-instance 'mopp:eql-specializer :object (second spec))) (t spec))) (clos:method-specializers method))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Build the package ;; we can't jsut do a do-external-symbols since we mess with the ;; package and that would put us in implementation dependent ;; territory, so we first build up a list of all the external symbols ;; in mopp and then work on that list. (let ((external-symbols '())) (do-external-symbols (sym (find-package :it.bese.arnesi.mopp)) (push sym external-symbols)) (dolist (sym external-symbols) (unless (provide-mopp-symbol sym #+openmcl :openmcl #+sbcl :sbcl #+cmu :cmu #+lispworks :lispworks) (warn "Unimplemented MOP symbol: ~S" sym)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Copyright (C) 2004 Edward Marco Baringer ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without ;;;; modification, are permitted provided that the following conditions are ;;;; met: ;;;; ;;;; - Redistributions of source code must retain the above copyright ;;;; notice, this list of conditions and the following disclaimer. ;;;; ;;;; - Redistributions in binary form must reproduce the above copyright ;;;; notice, this list of conditions and the following disclaimer in the ;;;; documentation and/or other materials provided with the distribution. ;;;; ;;;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names ;;;; of its contributors may be used to endorse or promote products ;;;; derived from this software without specific prior written permission. ;;;; ;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -Marco Ring the bells that still can ring. Forget your perfect offering. There is a crack in everything. That's how the light gets in. -Leonard Cohen From tfb at OCF.Berkeley.EDU Sun Oct 3 17:58:01 2004 From: tfb at OCF.Berkeley.EDU (Thomas F. Burdick) Date: Sun, 3 Oct 2004 10:58:01 -0700 Subject: [Small-cl-src] Collection utility Message-ID: <16736.15785.910251.346525@conquest.OCF.Berkeley.EDU> #| In 2001, I spent a little too much time thinking about the optimal interface to a collection utility, as evidenced by this thread on comp.lang.lisp: http://groups.google.com/groups?threadm=xcvsnbgix4v.fsf%40famine.OCF.Berkeley.EDU I'd thought I posted the collection utility I wrote as a result, but I can't find it anywhere. So, three years later, here it is. |# ;;; Copyright 2001, 2002, Thomas F. Burdick ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. (defpackage :org.no-carrier.collectors (:use :cl) (:export #:with-collectors #:collect)) (in-package #:org.no-carrier.collectors) (defmacro with-collectors ((&rest collectors) &body forms) "Evaluate FORMS with collectors established as specified by COLLECTORS. Each form in COLLECTORS can be a symbol, or a list of the form: (var &optional initial-value (fun name)) For each collector, a symbol-macro and a function are defined, allowing one to use the collector as either a variable or a function. The function takes one optional argument which is collected, if present. It returns the collected list so far. The initial value of the list being collected into will be INITIAL-VALUE. The list may be changed later by SETFing the collector. Care should be exercised, however, as this list will be modified." (loop for form in collectors for (head tail fun initvar initform) = (destructuring-bind (var &optional initform (fun var)) (if (listp form) form (list form)) (list var (gensym "TAIL-") fun (gensym "INIT-") initform)) collect `(,initvar ,initform) into inits collect `(,head ,initvar) into vars collect `(,tail (last ,initvar)) into vars collect head into var-names collect `(,fun (&optional (item nil itemp)) (when itemp (let ((new-cell (list item))) (if (consp ,tail) (setf (cdr ,tail) new-cell ,tail new-cell) (setf ,head new-cell ,tail new-cell)))) ,head) into funs collect fun into fun-names collect `((setf ,fun) (new-list &optional (item nil itemp)) (when itemp (,fun item)) (setf ,head new-list ,tail (last new-list)) ,head) into setfs collect `(setf ,fun) into setf-names collect `(,head (,fun)) into symbol-macros finally (return `(let ,inits (let ,vars (flet ,funs (declare (inline , at fun-names)) (flet ,setfs (declare (inline , at setf-names)) (symbol-macrolet ,symbol-macros (%with-more-collectors (,var-names ,fun-names) , at forms))))))))) (define-symbol-macro %collector-alist nil) (defmacro collect (item &key into &environment env) "Collect ITEM into the collector INTO, which should be the collector's name as a variable." (let* ((alist (macroexpand-1 '%collector-alist env)) (fun (cdr (assoc into alist)))) (if fun `(,fun ,item) (error "Attempt to collect into unknown collector ~S." into)))) (defmacro %with-more-collectors ((vars funs) &body forms &environment env) (let ((alist (nconc (mapcar #'cons vars funs) (macroexpand-1 '%collector-alist env)))) `(symbol-macrolet ((%collector-alist ,alist)) , at forms))) From csr21 at cam.ac.uk Tue Oct 19 18:16:31 2004 From: csr21 at cam.ac.uk (Christophe Rhodes) Date: Tue, 19 Oct 2004 19:16:31 +0100 Subject: [Small-cl-src] "simple" X11 clipboard client Message-ID: #| Howdy, I found myself wondering how hard it would be to make an X client which plays nice with select-and-paste (as seen by all the other X clients out there). The answer seems to be "quite hard", but here's a step along the road: a translation of some C test code, yielding a proof-of-concept clipboard client. Pastes both to and from the client work: a paste of text to the client yields printed messages to the lisp's standard output, and pastes while the client owns PRIMARY (left-click in the window) cause a silly piece of text to be pasted. Christophe |# -------------- next part -------------- An embedded and charset-unspecified text was scrubbed... Name: clipboard.lisp URL: From e9626484 at stud3.tuwien.ac.at Wed Oct 20 13:08:55 2004 From: e9626484 at stud3.tuwien.ac.at (Helmut Eller) Date: Wed, 20 Oct 2004 15:08:55 +0200 Subject: [Small-cl-src] (loop for (key value) in-hash table do ...) Message-ID: ;;; A little hack to get nicer syntax for hash-tables with LOOP. ;;; Works in CMUCL. ;;; ;;; Example: #| ;; cons up some random hash table (setq *htab* (let ((htab (make-hash-table))) (dotimes (i 50 htab) (setf (gethash i htab) (cons (random 200) (random (1+ i))))))) ;; convert it to a list (loop for (i (r1 . r2)) in-hash *htab* collect (list i r1 r2)) |# (in-package :ansi-loop) ;; Add a for-in-hash clause to loop. ;; (loop for (key value) in-hash ...) (defun loop-for-in-hash (key-val htab-form type) (declare (ignore type)) (destructuring-bind (key val) key-val (let ((more? (loop-gentemp 'more?)) (next (loop-gentemp 'next)) (htab (loop-gentemp 'htab)) (key-tmp (loop-gentemp 'key-tmp)) (val-tmp (loop-gentemp 'val-tmp))) (loop-make-variable htab htab-form nil) ; bind htab first (loop-make-variable more? nil nil) (loop-make-variable key-tmp nil nil) (loop-make-variable val-tmp nil nil) (push `(with-hash-table-iterator (,next ,htab)) *loop-wrappers*) (loop-make-iteration-variable key nil 't) (loop-make-iteration-variable val nil 't) (list `(progn (multiple-value-setq (,more? ,key-tmp ,val-tmp) (,next)) (not ,more?)) (list key key-tmp val val-tmp))))) (let* ((env *loop-ansi-universe*) (htab (loop-universe-for-keywords env))) (setf (gethash (string :in-hash) htab) (list 'loop-for-in-hash))) From ingvar at cathouse.bofh.se Wed Oct 20 18:15:37 2004 From: ingvar at cathouse.bofh.se (Ingvar) Date: Wed, 20 Oct 2004 19:15:37 +0100 Subject: [Small-cl-src] Netflow log reader (for the flowd logger from www.mindrot.org) Message-ID: ;;; This is (C) Ingvar Mattsson, 2004 ;;; ;;; This code uses the file format specification outlined in store.h ;;; in the netflow logger daemon downloadable from ;;; http://www.mindrot.org/flowd.html ;;; ;;; This code is available under the BSD license, please preserve the ;;; relevant copyright notices. ;;; ;;; The store.h file is: ;;; /* ;;; * Copyright (c) 2004 Damien Miller ;;; * ;;; * Permission to use, copy, modify, and distribute this software for any ;;; * purpose with or without fee is hereby granted, provided that the above ;;; * copyright notice and this permission notice appear in all copies. ;;; * ;;; * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES ;;; * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF ;;; * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ;;; * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES ;;; * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ;;; * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ;;; * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ;;; */ (defpackage #:flowd (:use #:cl) (:shadow #:tag #:stream) (:export #:+store-magic+ #:+store-version+ #:store-field-tag #:store-field-recv-time #:store-field-proto-flags-tos #:store-field-agent-addr4 #:store-field-agent-addr6 #:store-field-src-addr4 #:store-field-src-addr6 #:store-field-dst-addr4 #:store-field-dst-addr6 #:store-field-gateway-addr4 #:store-field-gateway-addr6 #:store-field-srcdst-port #:store-field-packets #:store-field-octets #:store-field-if-indices #:store-field-agent-info #:store-field-flow-times #:store-field-as-info #:store-field-flow-engine-info #:store-field-crc32 #:store-field-all #:open-log #:read-flow #:close-log #:fields #:tag #:recv-time #:proto-flags-tos #:agent-addr #:src-addr #:dst-addr #:gateway-addr #:src-port #:dst-port #:packets #:if-index-in #:if-index-out #:sys-uptime-ms #:time-sec #:time-nanosec #:netflow-version #:flow-start #:flow-finish #:src-as #:dst-as #:src-mask #:dst-mask #:engine-type #:engine-id #:flow-sequence #:src-net #:dst-net #:octets #:packets #:start-time #:format-ipv4)) (in-package #:flowd) (defvar *ipv4-netmasks* (apply #'vector (loop for n from 0 to 32 for mask = 0 then (logior #x80000000 (ash mask -1)) collect mask))) (defconstant +store-magic+ #x012cf047) (defconstant +store-version+ 2) (defconstant +store-field-tag+ (ash 1 0)) (defconstant +store-field-recv-time+ (ash 1 1)) (defconstant +store-field-proto-flags-tos+ (ash 1 2)) (defconstant +store-field-agent-addr4+ (ash 1 3)) (defconstant +store-field-agent-addr6+ (ash 1 4)) (defconstant +store-field-src-addr4+ (ash 1 5)) (defconstant +store-field-src-addr6+ (ash 1 6)) (defconstant +store-field-dst-addr4+ (ash 1 7)) (defconstant +store-field-dst-addr6+ (ash 1 8)) (defconstant +store-field-gateway-addr4+ (ash 1 9)) (defconstant +store-field-gateway-addr6+ (ash 1 10)) (defconstant +store-field-srcdst-port+ (ash 1 11)) (defconstant +store-field-packets+ (ash 1 12)) (defconstant +store-field-octets+ (ash 1 13)) (defconstant +store-field-if-indices+ (ash 1 14)) (defconstant +store-field-agent-info+ (ash 1 15)) (defconstant +store-field-flow-times+ (ash 1 16)) (defconstant +store-field-as-info+ (ash 1 17)) (defconstant +store-field-flow-engine-info+ (ash 1 18)) (defconstant +store-field-crc32+ (ash 1 30)) (defconstant +store-field-all+ (1- (ash 1 19))) (defclass store-header () ((magic :reader magic :initarg :magic) (version :reader version :initarg :version) (start-time :reader start-time :initarg :start-time) (flags :reader flags :initarg :flags) (stream :reader stream :initarg :stream) )) (defclass flow () ((fields :accessor fields :initarg :fields :initform nil) (tag :accessor tag :initarg :tag :initform nil) (recv-time :accessor recv-time :initarg :recv-time :initform nil) (tcp-flags :accessor tcp-flags :initarg :tcp-flags :initform nil) (protocol :accessor protocol :initarg :protocol :initform nil) (tos :accessor tos :initarg :tos :initform nil) (agent-addr :accessor agent-addr :initarg :agent-addr :initform nil) (src-addr :accessor src-addr :initarg :src-addr :initform nil) (dst-addr :accessor dst-addr :initarg :dst-addr :initform nil) (gateway-addr :accessor gateway-addr :initarg :gateway-addr :initform nil) (src-port :accessor src-port :initarg :src-port :initform nil) (dst-port :accessor dst-port :initarg :dst-port :initform nil) (packets :accessor packets :initarg :packets :initform nil) (octets :accessor octets :initarg :octets :initform nil) (if-index-in :accessor if-index-in :initarg :if-index-in :initform nil) (if-index-out :accessor if-index-out :initarg :if-index-out :initform nil) (sys-uptime-ms :accessor sys-uptime-ms :initarg :sys-uptime-ms :initform nil) (time-sec :accessor time-sec :initarg :time-sec :initform nil) (time-nanosec :accessor time-nanosec :initarg :time-nanosec :initform nil) (netflow-version :accessor netflow-version :initarg :netflow-version :initform nil) (flow-start :accessor flow-start :initarg :flow-start :initform nil) (flow-finish :accessor flow-finish :initarg :flow-finish :initform nil) (src-as :accessor src-as :initarg :src-as :initform nil) (dst-as :accessor dst-as :initarg :dst-as :initform nil) (src-mask :accessor src-mask :initarg :src-mask :initform nil) (dst-mask :accessor dst-mask :initarg :dst-mask :initform nil) (engine-type :accessor engine-type :initarg :engine-type :initform nil) (engine-id :accessor engine-id :initarg :engine-id :initform nil) (flow-sequence :accessor flow-sequence :initarg :flow-sequence :initform nil) )) (defclass ipaddr () ((address :accessor address :initarg :address))) (defclass ipv4 (ipaddr) ()) (defclass ipv6 (ipaddr) ()) (defun make-ipv4 (addr) "This function is currently a no-op" ;;(make-instance 'ipv4 :address addr) (identity addr) ) (defun make-ipv6 (addr) "This function is currently a no-op" ;;(make-instance 'ipv6 :address addr) (identity addr) ) (defmacro when-flagged (flag &body body) "Checks if a given flag is set. The flag field is expected to be named FIELDS and is for use inside READ-FLOW only!" `(when (not (zerop (logand fields ,flag))) , at body)) (defun read-n-bytes (stream n) "Read from STREAM a total of N bytes, mung them together as a single integer. Expects 8-bit bytes." (let ((acc 0)) (loop for r from 1 to n do (setf acc (logior (ash acc 8) (read-byte stream)))) acc)) (defun read-flow (flow-header &optional flow-obj) "(read-flow &optional flow-object) This function reads one flow entry from a log file (return value from OPEN-LOG) and returns it. If a flow object is passed in as an optional parameter, this flow object is re-used for storage instead of allocating a new instance." (let ((stream (stream flow-header))) (let ((fields (read-n-bytes stream 4))) (let ((flow (if flow-obj (progn (setf (fields flow-obj) fields) flow-obj) (make-instance 'flow :fields fields))) pad) (when-flagged +store-field-tag+ (setf (tag flow) (read-n-bytes stream 4))) (when-flagged +store-field-recv-time+ (setf (recv-time flow) (read-n-bytes stream 4))) (when-flagged +store-field-proto-flags-tos+ (setf (tcp-flags flow) (read-n-bytes stream 1)) (setf (protocol flow) (read-n-bytes stream 1)) (setf (tos flow) (read-n-bytes stream 1)) (setf pad (read-n-bytes stream 1))) (when-flagged +store-field-agent-addr4+ (setf (agent-addr flow) (make-ipv4 (read-n-bytes stream 4)))) (when-flagged +store-field-agent-addr6+ (setf (agent-addr flow) (make-ipv6 (read-n-bytes stream 16)))) (when-flagged +store-field-src-addr4+ (setf (src-addr flow) (make-ipv4 (read-n-bytes stream 4)))) (when-flagged +store-field-src-addr6+ (setf (src-addr flow) (make-ipv6 (read-n-bytes stream 16)))) (when-flagged +store-field-dst-addr4+ (setf (dst-addr flow) (make-ipv4 (read-n-bytes stream 4)))) (when-flagged +store-field-dst-addr6+ (setf (dst-addr flow) (make-ipv6 (read-n-bytes stream 16)))) (when-flagged +store-field-gateway-addr4+ (setf (gateway-addr flow) (make-ipv4 (read-n-bytes stream 4)))) (when-flagged +store-field-gateway-addr6+ (setf (gateway-addr flow) (make-ipv6 (read-n-bytes stream 16)))) (when-flagged +store-field-srcdst-port+ (setf (src-port flow) (read-n-bytes stream 2)) (setf (dst-port flow) (read-n-bytes stream 2))) (when-flagged +store-field-packets+ (setf (packets flow) (read-n-bytes stream 8))) (when-flagged +store-field-octets+ (setf (octets flow) (read-n-bytes stream 8))) (when-flagged +store-field-if-indices+ (setf (if-index-in flow) (read-n-bytes stream 2)) (setf (if-index-out flow) (read-n-bytes stream 2))) (when-flagged +store-field-agent-info+ (setf (sys-uptime-ms flow) (read-n-bytes stream 4)) (setf (time-sec flow) (read-n-bytes stream 4)) (setf (time-nanosec flow) (read-n-bytes stream 4)) (setf (netflow-version flow) (read-n-bytes stream 2)) (setf pad (read-n-bytes stream 2))) (when-flagged +store-field-flow-times+ (setf (flow-start flow) (read-n-bytes stream 4)) (setf (flow-finish flow) (read-n-bytes stream 4))) (when-flagged +store-field-as-info+ (setf (src-as flow) (read-n-bytes stream 2)) (setf (dst-as flow) (read-n-bytes stream 2)) (setf (src-mask flow) (read-n-bytes stream 1)) (setf (dst-mask flow) (read-n-bytes stream 1)) (setf pad (read-n-bytes stream 2))) (when-flagged +store-field-flow-engine-info+ (setf (engine-type flow) (read-n-bytes stream 1)) (setf (engine-id flow) (read-n-bytes stream 1)) (setf pad (read-n-bytes stream 2)) (setf (flow-sequence flow) (read-n-bytes stream 4))) (when-flagged +store-field-crc32+ (setf pad (read-n-bytes stream 4))) flow)))) (defun open-log (file) "(open-log This function opens a new log file and returns a header structure containing the relevant file header information." (let ((stream (open file :element-type '(unsigned-byte 8) :direction :input))) (let ((magic (read-n-bytes stream 4))) (let ((version (read-n-bytes stream 4))) (let ((start-time (read-n-bytes stream 4))) (let ((flags (read-n-bytes stream 4))) (make-instance 'store-header :magic magic :version version :start-time start-time :flags flags :stream stream))))))) (defun close-log (flow) "(close-log flow) This function closes the log file associated with a storage header." (close (stream flow))) (defmacro formatted-addr (flow-obj slot) (let ((flags (case slot (dst-addr (list +store-field-dst-addr4+ +store-field-dst-addr6+)) (src-addr (list +store-field-src-addr4+ +store-field-src-addr6+)) (gateway-addr (list +store-field-gateway-addr4+ +store-field-gateway-addr6+)) (agent-addr (list +store-field-agent-addr4+ +store-field-agent-addr6+)))) (flow flow-obj)) `(format-addr ,flow ',flags (,slot ,flow)))) (defun format-addr (flow-obj flags chunk) (let ((flag4 (car flags)) (flag6 (cadr flags)) (fields (fields flow-obj))) (or (when (= flag4 (logand flag4 fields)) (format-ipv4 chunk)) (when (= flag6 (logand flag6 fields)) (format nil "~X" chunk))))) (defun format-ipv4 (chunk &optional stream mask) "(format-ipv4 binary-chunk &optiona stream mask) This function outputs an IPv4 address as a dotted quad to STREAM. If a netmask is passed in, it's outputted with the dotted quad in CIDR notation." (if mask (format stream "~D.~D.~D.~D/~D" (ldb (byte 8 24) chunk) (ldb (byte 8 16) chunk) (ldb (byte 8 8) chunk) (ldb (byte 8 0) chunk) mask) (format stream "~D.~D.~D.~D" (ldb (byte 8 24) chunk) (ldb (byte 8 16) chunk) (ldb (byte 8 8) chunk) (ldb (byte 8 0) chunk)))) (defun src-net (flow-obj &optional (stream nil) (formatted nil)) "(src-net flow-obj &optional stream formatted-p) This function extracts the source network and masks it against the relevant IPv4 netmask and returns the network part. If given a STREAM and FORMATTED-P is not null, the resulting netblock is emitted using FORMAT-IPV4 to the indicated stream." (let ((bitmask (logior +store-field-as-info+ +store-field-src-addr4+))) (when (= bitmask (logand (fields flow-obj) bitmask)) (let ((masklen (src-mask flow-obj))) (let ((netmask (aref *ipv4-netmasks* masklen))) (let ((netblock (logand (src-addr flow-obj) netmask))) (if formatted (format-ipv4 netblock stream masklen) netblock))))))) (defun dst-net (flow-obj &optional (stream nil) (formatted nil)) "(dst-net flow-obj &optional stream formatted-p) This function extracts the destination network and masks it against the relevant IPv4 netmask and returns the network part. If given a STREAM and FORMATTED-P is not null, the resulting netblock is emitted using FORMAT-IPV4 to the indicated stream." (let ((bitmask (logior +store-field-as-info+ +store-field-dst-addr4+))) (when (= bitmask (logand (fields flow-obj) bitmask)) (let ((masklen (dst-mask flow-obj))) (let ((netmask (aref *ipv4-netmasks* masklen))) (let ((netblock (logand (dst-addr flow-obj) netmask))) (if formatted (format-ipv4 netblock stream masklen) netblock))))))) -- //Ingvar