--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: attrib-class.lisp
+;;;; Purpose: Defines metaclass allowing use of attributes on slots
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Apr 2000
+;;;;
+;;;; $Id: attrib-class.lisp,v 1.1 2002/10/06 13:21:47 kevin Exp $
+;;;;
+;;;; This file, part of Genutils, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; Genutils users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+;;;; Defines a metaclass that allows the use of attributes (or subslots)
+;;;; on slots. Based on example in AMOP, but modified to use ACL's MOP.
+
+(in-package :genutils)
+
+(defclass attributes-dsd (mop::standard-direct-slot-definition)
+ ((attributes :initarg :attributes :initform nil
+ :accessor attributes)))
+
+(defclass attributes-esd (mop::standard-effective-slot-definition)
+ ((attributes :initarg :attributes :initform nil
+ :accessor slot-definition-attributes)))
+
+
+(defclass attributes-class (mop::standard-class)
+ ()
+ )
+
+(defmethod mop::direct-slot-definition-class ((cl attributes-class)
+ &rest iargs &key attributes)
+ (declare (ignorable attributes))
+;; (format t "attributes:~s iargs:~s~%" attributes iargs)
+ (find-class 'attributes-dsd))
+
+
+(defmethod mop::compute-effective-slot-definition :around
+ ((cl attributes-class) slot dsds)
+ (declare (ignorable slot))
+ (apply
+ #'make-instance 'attributes-esd
+ :attributes (remove-duplicates (gu:mapappend #'attributes dsds))
+ (excl::compute-effective-slot-definition-initargs cl dsds))
+ )
+
+
+#+ignore
+(defmethod mop::compute-effective-slot-definition ((cl attributes-class) slot dsds)
+ (declare (ignorable slot))
+ (let ((normal-slot (call-next-method)))
+ (setf (slot-definition-attributes normal-slot)
+ (remove-duplicates
+ (mapappend #'slot-definition-attributes dsds)))
+ normal-slot))
+
+
+(defmethod mop::compute-slots ((class attributes-class))
+ (let* ((normal-slots (call-next-method))
+ (alist
+ (mapcar
+ #'(lambda (slot)
+ (let ((attr-list (mapcar #'(lambda (attr) (cons attr nil))
+ (slot-definition-attributes slot))))
+ (when attr-list
+ (cons (mop::slot-definition-name slot) attr-list))))
+ normal-slots)))
+ (setq alist (delete nil alist))
+ (cons (mop::make-instance 'mop::standard-effective-slot-definition
+ :name 'all-attributes
+ :initform `',alist
+ :initfunction #'(lambda () alist))
+ normal-slots)))
+
+(defun slot-attribute (instance slot-name attribute)
+ (cdr (slot-attribute-bucket instance slot-name attribute)))
+
+(defun (setf slot-attribute) (new-value instance slot-name attribute)
+ (setf (cdr (slot-attribute-bucket instance slot-name attribute))
+ new-value))
+
+(defun slot-attribute-bucket (instance slot-name attribute)
+ (let* ((all-buckets (slot-value instance 'all-attributes))
+ (slot-bucket (assoc slot-name all-buckets)))
+ (unless slot-bucket
+ (error "The slot named ~S of ~S has no attributes."
+ slot-name instance))
+ (let ((attr-bucket (assoc attribute (cdr slot-bucket))))
+ (unless attr-bucket
+ (error "The slot named ~S of ~S has no attributes named ~S."
+ slot-name instance attribute))
+ attr-bucket)))
+
+
+#||
+(in-package :genutils)
+
+(defclass credit-rating ()
+ ((level :attributes (date-set time-set))
+ (id :attributes (person-setting)))
+ (:metaclass genutils:attributes-class))
+(defparameter cr (make-instance 'credit-rating))
+
+(format t "~&date-set: ~a" (gu:slot-attribute cr 'level 'date-set))
+(setf (gu:slot-attribute cr 'level 'date-set) "12/15/1990")
+(format t "~&date-set: ~a" (gu:slot-attribute cr 'level 'date-set))
+
+(defclass monitored-credit-rating (credit-rating)
+ ((level :attributes (last-checked interval date-set))
+ (cc :initarg :cc)
+ (id :attributes (verified))
+ )
+ (:metaclass gu:attributes-class))
+(defparameter mcr (make-instance 'monitored-credit-rating))
+
+(setf (gu:slot-attribute mcr 'level 'date-set) "01/05/2002")
+(format t "~&date-set for mcr: ~a" (gu:slot-attribute mcr 'level 'date-set))
+
+||#
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: buff-input.lisp
+;;;; Purpose: Buffered line input
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Apr 2000
+;;;;
+;;;; $Id: buff-input.lisp,v 1.1 2002/10/06 13:21:47 kevin Exp $
+;;;;
+;;;; This file, part of Genutils, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; Genutils users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+(in-package :genutils)
+
+(declaim (optimize (speed 3) (safety 0) (space 0) (debug 0)))
+
+(defconstant +max-field+ 10000)
+(defconstant +max-fields-per-line+ 20)
+(defconstant +field-delim+ #\|)
+(defconstant +eof-char+ #\rubout)
+(defconstant +newline+ #\Newline)
+
+(declaim (type character +eof-char+ +field-delim+ +newline+)
+ (type fixnum +max-field+ +max-fields-per-line+))
+
+;; Buffered fields parsing function
+;; Uses fill-pointer for size
+
+(defun make-fields-buffer (&optional (max-fields +max-fields-per-line+)
+ (max-field-len +max-field+))
+ (let ((bufs (make-array max-fields :element-type 'vector :fill-pointer 0 :adjustable nil)))
+ (dotimes (i +max-fields-per-line+)
+ (setf (aref bufs i) (make-array max-field-len :element-type 'character :fill-pointer 0 :adjustable nil)))
+ bufs))
+
+(defun read-buffered-fields (fields strm &optional (field-delim +field-delim+))
+ "Read a line from a stream into a field buffers"
+ (declare (type base-char field-delim)
+ (type vector fields))
+ (setf (fill-pointer fields) 0)
+ (do ((ifield 0 (1+ ifield))
+ (linedone nil)
+ (eof nil))
+ (linedone (if eof 'eof fields))
+ (declare (type fixnum ifield)
+ (type boolean linedone eof))
+ (let ((field (aref fields ifield)))
+ (declare (type base-string field))
+ (do ((ipos 0)
+ (fielddone nil)
+ (rc (read-char strm nil +eof-char+)
+ (read-char strm nil +eof-char+)))
+ (fielddone (unread-char rc strm))
+ (declare (type fixnum ipos)
+ (type base-char rc)
+ (type boolean fielddone))
+ (cond
+ ((char= rc field-delim)
+ (setf (fill-pointer field) ipos)
+ (setq fielddone t))
+ ((char= rc +newline+)
+ (setf (fill-pointer field) ipos)
+ (setf (fill-pointer fields) ifield)
+ (setq fielddone t)
+ (setq linedone t))
+ ((char= rc +eof-char+)
+ (setf (fill-pointer field) ipos)
+ (setf (fill-pointer fields) ifield)
+ (setq fielddone t)
+ (setq linedone t)
+ (setq eof t))
+ (t
+ (setf (char field ipos) rc)
+ (incf ipos)))))))
+
+;; Buffered fields parsing
+;; Does not use fill-pointer
+;; Returns 2 values -- string array and length array
+(defstruct field-buffers
+ (nfields 0 :type fixnum)
+ (buffers)
+ (field-lengths))
+
+(defmethod print-object ((f field-buffers) s)
+ (format s "#<~d>~%" (field-buffers-nfields f)))
+
+(defun make-fields-buffer2 (&optional (max-fields +max-fields-per-line+)
+ (max-field-len +max-field+))
+ (let ((bufs (make-array max-fields :element-type 'vector :fill-pointer nil :adjustable nil))
+ (bufstruct (make-field-buffers)))
+ (dotimes (i +max-fields-per-line+)
+ (setf (aref bufs i) (make-array max-field-len :element-type 'character :fill-pointer nil :adjustable nil)))
+ (setf (field-buffers-buffers bufstruct) bufs)
+ (setf (field-buffers-field-lengths bufstruct) (make-array +max-fields-per-line+
+ :element-type 'fixnum :fill-pointer nil :adjustable nil))
+ (setf (field-buffers-nfields bufstruct) 0)
+ bufstruct))
+
+
+(defun read-buffered-fields2 (fields strm &optional (field-delim +field-delim+))
+ "Read a line from a stream into a field buffers"
+ (declare (character field-delim))
+ (setf (field-buffers-nfields fields) 0)
+ (do ((ifield 0 (1+ ifield))
+ (linedone nil)
+ (eof nil))
+ (linedone (if eof 'eof fields))
+ (declare (fixnum ifield)
+ (t linedone eof))
+ (let ((field (aref (field-buffers-buffers fields) ifield)))
+ (declare (simple-string field))
+ (do ((ipos 0)
+ (fielddone nil)
+ (rc (read-char strm nil +eof-char+)
+ (read-char strm nil +eof-char+)))
+ (fielddone (unread-char rc strm))
+ (declare (fixnum ipos)
+ (character rc)
+ (t fielddone))
+ (cond
+ ((char= rc field-delim)
+ (setf (aref (field-buffers-field-lengths fields) ifield) ipos)
+ (setq fielddone t))
+ ((char= rc +newline+)
+ (setf (aref (field-buffers-field-lengths fields) ifield) ipos)
+ (setf (field-buffers-nfields fields) ifield)
+ (setq fielddone t)
+ (setq linedone t))
+ ((char= rc +eof-char+)
+ (setf (aref (field-buffers-field-lengths fields) ifield) ipos)
+ (setf (field-buffers-nfields fields) ifield)
+ (setq fielddone t)
+ (setq linedone t)
+ (setq eof t))
+ (t
+ (setf (char field ipos) rc)
+ (incf ipos)))))))
+
+(defun bfield (fields i)
+ (if (>= i (field-buffers-nfields fields))
+ nil
+ (subseq (aref (field-buffers-buffers fields) i) 0 (aref (field-buffers-field-lengths fields) i))))
+
+;;; Buffered line parsing function
+
+(defconstant +max-line+ 20000)
+(let ((linebuffer (make-array +max-line+
+ :element-type 'character
+ :fill-pointer 0)))
+ (defun read-buffered-line (strm)
+ "Read a line from astream into a vector buffer"
+ (let ((pos 0)
+ (done nil))
+ (declare (fixnum pos) (t done))
+ (setf (fill-pointer linebuffer) 0)
+ (do ((c (read-char strm nil +eof-char+)
+ (read-char strm nil +eof-char+)))
+ (done (progn
+ (unless (eql c +eof-char+) (unread-char c strm))
+ (if (eql c +eof-char+) 'eof linebuffer)))
+ (declare (character c))
+ (cond
+ ((char= c #\Newline)
+ (unless (zerop pos)
+ (setf (fill-pointer linebuffer) (1- pos)))
+ (setf done t))
+ ((char= +eof-char+)
+ (setf done t))
+ (t
+ (setf (char linebuffer pos) c)
+ (incf pos)))))))
+
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: cl-symbols.lisp
+;;;; Purpose: Returns all defined Common Lisp symbols
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Apr 2000
+;;;;
+;;;; $Id: cl-symbols.lisp,v 1.1 2002/10/06 13:21:47 kevin Exp $
+;;;;
+;;;; This file, part of Genutils, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; Genutils users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+(in-package :genutils)
+
+(defun cl-symbols ()
+ (append (cl-variables) (cl-functions)))
+
+(defun cl-variables ()
+ (let ((vars '()))
+ (do-symbols (s 'common-lisp)
+ (multiple-value-bind (sym status)
+ (find-symbol (symbol-name s) 'common-lisp)
+ (when (and (or (eq status :external)
+ (eq status :internal))
+ (boundp sym))
+ (push sym vars))))
+ (nreverse vars)))
+
+(defun cl-functions ()
+ (let ((funcs '()))
+ (do-symbols (s 'common-lisp)
+ (multiple-value-bind (sym status)
+ (find-symbol (symbol-name s) 'common-lisp)
+ (when (and (or (eq status :external)
+ (eq status :internal))
+ (fboundp sym))
+ (push sym funcs))))
+ (nreverse funcs)))
--- /dev/null
+cl-kmrcl (1.0-1) unstable; urgency=low
+
+ * Initial Release.
+
+ -- Kevin M. Rosenberg <kmr@debian.org> Sat, 5 Oct 2002 13:19:33 -0600
+
--- /dev/null
+Source: cl-kmrcl
+Section: devel
+Priority: optional
+Maintainer: Kevin M. Rosenberg <kmr@debian.org>
+Build-Depends-Indep: debhelper (>= 4.0.0)
+Standards-Version: 3.5.7.0
+
+Package: cl-kmrcl
+Architecture: all
+Depends: ${shlibs:Depends}
+Description: General Utilities for Common Lisp Programs
+ This package includes general purpose utilities for Common Lisp
+ programs. It is packages for Debian primarily to support more complex
+ Common Lisp packages by the upstream author Kevin Rosenberg.
+
--- /dev/null
+This package was debianized by Kevin M. Rosenberg <kmr@debian.org> on
+Sat, 5 Oct 2002 13:19:33 -0600.
+
+It was downloaded from ftp://kmrcl.b9.com
+
+Upstream Author: Kevin M. Rosenberg <kevin@rosenberg.net>
+
+Changes compared to upstream: none
+
+Copyright:
+
+Copyright (C) 2000-2002 by Kevin M. Rosenberg.
+It is governed by the GNU GPL license, a copy of which
+is located on your Debian file system as /usr/share/common-licenses/GPL.
+
--- /dev/null
+#! /bin/sh
+# postinst script for cl-kmrcl
+#
+# see: dh_installdeb(1)
+
+set -e
+
+# package name according to lisp
+LISP_PKG=kmrcl
+
+# summary of how this script can be called:
+# * <postinst> `configure' <most-recently-configured-version>
+# * <old-postinst> `abort-upgrade' <new version>
+# * <conflictor's-postinst> `abort-remove' `in-favour' <package>
+# <new-version>
+# * <deconfigured's-postinst> `abort-deconfigure' `in-favour'
+# <failed-install-package> <version> `removing'
+# <conflicting-package> <version>
+# for details, see http://www.debian.org/doc/debian-policy/ or
+# the debian-policy package
+#
+# quoting from the policy:
+# Any necessary prompting should almost always be confined to the
+# post-installation script, and should be protected with a conditional
+# so that unnecessary prompting doesn't happen if a package's
+# installation fails and the `postinst' is called with `abort-upgrade',
+# `abort-remove' or `abort-deconfigure'.
+
+case "$1" in
+ configure)
+ /usr/sbin/register-common-lisp-source ${LISP_PKG}
+ ;;
+ abort-upgrade|abort-remove|abort-deconfigure)
+ ;;
+ *)
+ echo "postinst called with unknown argument \`$1'" >&2
+ exit 1
+ ;;
+esac
+
+# dh_installdeb will replace this with shell code automatically
+# generated by other debhelper scripts.
+
+#DEBHELPER#
+
+exit 0
--- /dev/null
+#! /bin/sh
+# prerm script for cl-kmrcl
+#
+# see: dh_installdeb(1)
+
+set -e
+
+# package name according to lisp
+LISP_PKG=kmrcl
+
+# summary of how this script can be called:
+# * <prerm> `remove'
+# * <old-prerm> `upgrade' <new-version>
+# * <new-prerm> `failed-upgrade' <old-version>
+# * <conflictor's-prerm> `remove' `in-favour' <package> <new-version>
+# * <deconfigured's-prerm> `deconfigure' `in-favour'
+# <package-being-installed> <version> `removing'
+# <conflicting-package> <version>
+# for details, see http://www.debian.org/doc/debian-policy/ or
+# the debian-policy package
+
+
+case "$1" in
+ remove|upgrade|deconfigure)
+ /usr/sbin/unregister-common-lisp-source ${LISP_PKG}
+ ;;
+ failed-upgrade)
+ ;;
+ *)
+ echo "prerm called with unknown argument \`$1'" >&2
+ exit 1
+ ;;
+esac
+
+# dh_installdeb will replace this with shell code automatically
+# generated by other debhelper scripts.
+
+#DEBHELPER#
+
+exit 0
+
+
--- /dev/null
+#!/usr/bin/make -f
+
+export DH_COMPAT=4
+
+pkg := kmrcl
+debpkg := cl-kmrcl
+
+
+clc-source := usr/share/common-lisp/source
+clc-systems := usr/share/common-lisp/systems
+clc-kmrcl := $(clc-source)/$(pkg)
+
+doc-dir := usr/share/doc/$(debpkg)
+
+
+configure: configure-stamp
+configure-stamp:
+ dh_testdir
+ # Add here commands to configure the package.
+
+ touch configure-stamp
+
+
+build: build-stamp
+
+build-stamp: configure-stamp
+ dh_testdir
+ # Add here commands to compile the package.
+ touch build-stamp
+
+clean:
+ dh_testdir
+ dh_testroot
+ rm -f build-stamp configure-stamp
+ # Add here commands to clean up after the build process.
+ rm -f debian/cl-kmrcl.postinst.* debian/cl-kmrcl.prerm.*
+ dh_clean
+
+install: build
+ dh_testdir
+ dh_testroot
+ dh_clean -k
+ # Add here commands to install the package into debian/kmrcl.
+ dh_installdirs $(clc-systems) $(clc-kmrcl) $(doc-dir)
+ dh_install kmrcl.asd $(shell echo *.lisp) $(clc-kmrcl)
+ dh_link $(clc-kmrcl)/kmrcl.asd $(clc-systems)/kmrcl.asd
+
+# Build architecture-independent files here.
+binary-indep: build install
+
+
+# Build architecture-dependent files here.
+binary-arch: build install
+ dh_testdir
+ dh_testroot
+# dh_installdebconf
+ dh_installdocs
+# dh_installmenu
+# dh_installlogrotate
+# dh_installemacsen
+# dh_installpam
+# dh_installmime
+# dh_installinit
+# dh_installcron
+# dh_installman
+# dh_installinfo
+# dh_undocumented
+ dh_installchangelogs
+ dh_strip
+ dh_compress
+ dh_fixperms
+# dh_makeshlibs
+ dh_installdeb
+# dh_perl
+ dh_shlibdeps
+ dh_gencontrol
+ dh_md5sums
+ dh_builddeb
+
+binary: binary-indep binary-arch
+.PHONY: build clean binary-indep binary-arch binary install configure
+
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: genutils.lisp
+;;;; Purpose: Main general utility functions for GENUTILS package
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Apr 2000
+;;;;
+;;;; $Id: genutils.lisp,v 1.1 2002/10/06 13:21:47 kevin Exp $
+;;;;
+;;;; This file, part of Genutils, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; Genutils users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+
+(in-package :genutils)
+
+(declaim (optimize (speed 3) (safety 1)))
+
+(defmacro bind-when ((bind-var boundForm) &body body)
+ `(let ((,bind-var ,boundForm))
+ (declare (ignore-if-unused ,bind-var))
+ (when ,bind-var
+ ,@body)))
+
+(defmacro bind-if ((bind-var boundForm) yup &optional nope)
+ `(let ((,bind-var ,boundForm))
+ (if ,bind-var
+ ,yup
+ ,nope)))
+
+;; Anaphoric macros
+
+(defmacro aif (test then &optional else)
+ `(let ((it ,test))
+ (if it ,then ,else)))
+
+(defmacro awhen (test-form &body body)
+ `(aif ,test-form
+ (progn ,@body)))
+
+(defmacro awhile (expr &body body)
+ `(do ((it ,expr ,expr))
+ ((not it))
+ ,@body))
+
+(defmacro aand (&rest args)
+ (cond ((null args) t)
+ ((null (cdr args)) (car args))
+ (t `(aif ,(car args) (aand ,@(cdr args))))))
+
+(defmacro acond (&rest clauses)
+ (if (null clauses)
+ nil
+ (let ((cl1 (car clauses))
+ (sym (gensym)))
+ `(let ((,sym ,(car cl1)))
+ (if ,sym
+ (let ((it ,sym)) ,@(cdr cl1))
+ (acond ,@(cdr clauses)))))))
+
+(defmacro alambda (parms &body body)
+ `(labels ((self ,parms ,@body))
+ #'self))
+
+
+(defmacro aif2 (test &optional then else)
+ (let ((win (gensym)))
+ `(multiple-value-bind (it ,win) ,test
+ (if (or it ,win) ,then ,else))))
+
+(defmacro awhen2 (test &body body)
+ `(aif2 ,test
+ (progn ,@body)))
+
+(defmacro awhile2 (test &body body)
+ (let ((flag (gensym)))
+ `(let ((,flag t))
+ (while ,flag
+ (aif2 ,test
+ (progn ,@body)
+ (setq ,flag nil))))))
+
+(defmacro acond2 (&rest clauses)
+ (if (null clauses)
+ nil
+ (let ((cl1 (car clauses))
+ (val (gensym))
+ (win (gensym)))
+ `(multiple-value-bind (,val ,win) ,(car cl1)
+ (if (or ,val ,win)
+ (let ((it ,val)) ,@(cdr cl1))
+ (acond2 ,@(cdr clauses)))))))
+
+
+;; Debugging
+
+(defmacro mac (expr)
+"Expand a macro"
+ `(pprint (macroexpand-1 ',expr)))
+
+(defmacro print-form-and-results (form)
+ `(format t "~&~A --> ~S~%" (write-to-string ',form) ,form))
+
+(defun show (&optional (what :variables) (package *package*))
+ (ecase what
+ (:variables (show-variables package))
+ (:functions (show-functions package))))
+
+(defun show-variables (package)
+ (do-symbols (s package)
+ (multiple-value-bind (sym status)
+ (find-symbol (symbol-name s) package)
+ (when (and (or (eq status :external)
+ (eq status :internal))
+ (boundp sym))
+ (format t "~&Symbol ~S~T -> ~S~%"
+ sym
+ (symbol-value sym))))))
+
+(defun show-functions (package)
+ (do-symbols (s package)
+ (multiple-value-bind (sym status)
+ (find-symbol (symbol-name s) package)
+ (when (and (or (eq status :external)
+ (eq status :internal))
+ (fboundp sym))
+ (format t "~&Function ~S~T -> ~S~%"
+ sym
+ (symbol-function sym))))))
+
+#+allegro
+(ff:def-foreign-call (memory-status-dump "memory_status_dump")
+ ()
+ :strings-convert t)
+
+
+;; Ensure functions
+
+(defmacro ensure-integer (obj)
+ "Ensure object is an integer. If it is a string, then parse it"
+ `(if (stringp ,obj)
+ (parse-integer ,obj)
+ ,obj))
+
+;; Lists
+
+(defun mklist (obj)
+ "Make into list if atom"
+ (if (listp obj) obj (list obj)))
+
+(defun filter (fn lst)
+ "Filter a list by function, eliminate elements where fn returns nil"
+ (let ((acc nil))
+ (dolist (x lst)
+ (let ((val (funcall fn x)))
+ (if val (push val acc))))
+ (nreverse acc)))
+
+
+;; Functions
+
+(defun memo-proc (fn)
+ "Memoize results of call to fn, returns a closure with hash-table"
+ (let ((cache (make-hash-table :test #'equal)))
+ #'(lambda (&rest args)
+ (multiple-value-bind (val foundp) (gethash args cache)
+ (if foundp
+ val
+ (setf (gethash args cache)
+ (apply fn args)))))))
+
+(defun memoize (fn-name)
+ (setf (fdefinition fn-name) (memo-proc (fdefinition fn-name))))
+
+(defmacro defun-memo (fn args &body body)
+ "Define a memoized function"
+ `(memoize (defun ,fn ,args . ,body)))
+
+(defmacro _f (op place &rest args)
+ (multiple-value-bind (vars forms var set access)
+ (get-setf-expansion place)
+ `(let* (,@(mapcar #'list vars forms)
+ (,(car var) (,op ,access ,@args)))
+ ,set)))
+
+(defun compose (&rest fns)
+ (if fns
+ (let ((fn1 (car (last fns)))
+ (fns (butlast fns)))
+ #'(lambda (&rest args)
+ (reduce #'funcall fns
+ :from-end t
+ :initial-value (apply fn1 args))))
+ #'identity))
+
+;;; Loop macros
+
+(defmacro until (test &body body)
+ `(do ()
+ (,test)
+ ,@body))
+
+(defmacro while (test &body body)
+ `(do ()
+ ((not ,test))
+ ,@body))
+
+(defmacro for ((var start stop) &body body)
+ (let ((gstop (gensym)))
+ `(do ((,var ,start (1+ ,var))
+ (,gstop ,stop))
+ ((> ,var ,gstop))
+ ,@body)))
+
+
+;;; Keyword functions
+
+(defun remove-keyword (key arglist)
+ (loop for sublist = arglist then rest until (null sublist)
+ for (elt arg . rest) = sublist
+ unless (eq key elt) append (list elt arg)))
+
+(defun remove-keywords (key-names args)
+ (loop for ( name val ) on args by #'cddr
+ unless (member (symbol-name name) key-names
+ :key #'symbol-name :test 'equal)
+ append (list name val)))
+
+(defmacro in (obj &rest choices)
+ (let ((insym (gensym)))
+ `(let ((,insym ,obj))
+ (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c))
+ choices)))))
+
+(defmacro mean (&rest args)
+ `(/ (+ ,@args) ,(length args)))
+
+(defmacro with-gensyms (syms &body body)
+ `(let ,(mapcar #'(lambda (s) `(,s (gensym)))
+ syms)
+ ,@body))
+
+
+;;; Mapping
+
+(defun mapappend (fn list)
+ (apply #'append (mapcar fn list)))
+
+
+(defun mapcar-append-string-nontailrec (func v)
+"Concatenate results of mapcar lambda calls"
+ (aif (car v)
+ (concatenate 'string (funcall func it)
+ (mapcar-append-string-nontailrec func (cdr v)))
+ ""))
+
+
+(defun mapcar-append-string (func v &optional (accum ""))
+"Concatenate results of mapcar lambda calls"
+ (aif (car v)
+ (mapcar-append-string
+ func
+ (cdr v)
+ (concatenate 'string accum (funcall func it)))
+ accum))
+
+
+(defun mapcar2-append-string-nontailrec (func la lb)
+"Concatenate results of mapcar lambda call's over two lists"
+ (let ((a (car la))
+ (b (car lb)))
+ (if (and a b)
+ (concatenate 'string (funcall func a b)
+ (mapcar2-append-string-nontailrec func (cdr la) (cdr lb)))
+ "")))
+
+(defun mapcar2-append-string (func la lb &optional (accum ""))
+"Concatenate results of mapcar lambda call's over two lists"
+ (let ((a (car la))
+ (b (car lb)))
+ (if (and a b)
+ (mapcar2-append-string
+ func
+ (cdr la)
+ (cdr lb)
+ (concatenate 'string accum (funcall func a b)))
+ accum)))
+
+;;; Strings
+
+(defmacro string-append (outputstr &rest args)
+ `(setq ,outputstr (concatenate 'string ,outputstr ,@args)))
+
+(defmacro string-field-append (outputstr &rest args)
+ `(setq ,outputstr (concatenate 'string ,outputstr ,@args)))
+
+(defun list-to-string (lst)
+ "Converts a list to a string, doesn't include any delimiters between elements"
+ (format nil "~{~A~}" lst))
+
+(defun count-string-words (str)
+ (declare (simple-string str)
+ (optimize (speed 3) (safety 0)))
+ (let ((n-words 0)
+ (in-word nil))
+ (declare (fixnum n-words))
+ (dotimes (i (length str))
+ (let ((ch (char str i)))
+ (declare (character ch))
+ (if (alphanumericp ch)
+ (unless in-word
+ (incf n-words)
+ (setq in-word t))
+ (setq in-word nil))))
+ n-words))
+
+#+excl
+(defun delimited-string-to-list (string &optional (separator #\space))
+ (excl:delimited-string-to-list string separator))
+
+#-excl
+(defun delimited-string-to-list (sequence &optional (separator #\space))
+"Split a string by a delimitor"
+ (loop
+ with start = 0
+ for end = (position separator sequence :start start)
+ collect (subseq sequence start end)
+ until (null end)
+ do
+ (setf start (1+ end))))
+
+#+excl
+(defun list-to-delimited-string (list &optional (separator #\space))
+ (excl:list-to-delimited-string list separator))
+
+#-excl
+(defun list-to-delimited-string (list &optional (separator #\space))
+ (let ((output (when list (format nil "~A" (car list)))))
+ (dolist (obj (rest list))
+ (setq output (concatenate 'string output
+ (format nil "~A" separator)
+ (format nil "~A" obj))))
+ output))
+
+(defun string-invert (str)
+ "Invert case of a string"
+ (declare (optimize (speed 3) (compilation-speed 0) (debug 0) (safety 0))
+ (simple-string str))
+ (let ((up nil) (down nil))
+ (block skip
+ (loop for char of-type character across str do
+ (cond ((upper-case-p char) (if down (return-from skip str) (setf up t)))
+ ((lower-case-p char) (if up (return-from skip str) (setf down t)))))
+ (if up (string-downcase str) (string-upcase str)))))
+
+(defun add-sql-quotes (s)
+ (substitute-string-for-char s #\' "''"))
+
+(defun escape-backslashes (s)
+ (substitute-string-for-char s #\\ "\\\\"))
+
+(defun substitute-string-for-char (procstr match-char subst-str)
+"Substitutes a string for a single matching character of a string"
+ (let ((pos (position match-char procstr)))
+ (if pos
+ (concatenate 'string
+ (subseq procstr 0 pos) subst-str
+ (substitute-string-for-char (subseq procstr (1+ pos)) match-char subst-str))
+ procstr)))
+
+(defun string-substitute (string substring replacement-string)
+ "String substitute by Larry Hunter. Obtained from Google"
+ (let ((substring-length (length substring))
+ (last-end 0)
+ (new-string ""))
+ (do ((next-start
+ (search substring string)
+ (search substring string :start2 last-end)))
+ ((null next-start)
+ (concatenate 'string new-string (subseq string last-end)))
+ (setq new-string
+ (concatenate 'string
+ new-string
+ (subseq string last-end next-start)
+ replacement-string))
+ (setq last-end (+ next-start substring-length)))))
+
+
+(defun string-trim-last-character (s)
+"Return the string less the last character"
+ (subseq s 0 (1- (length s))))
+
+(defun string-hash (str &optional (bitmask 65535))
+ (let ((hash 0))
+ (declare (fixnum hash)
+ (simple-string str))
+ (dotimes (i (length str))
+ (declare (fixnum i))
+ (setq hash (+ hash (char-code (char str i)))))
+ (logand hash bitmask)))
+
+(defun string-not-null? (str)
+ (and str (not (zerop (length str)))))
+
+(defun whitespace? (c)
+ (declare (character c))
+ (declare (optimize (speed 3) (safety 0)))
+ (or (char= c #\Space) (char= c #\Tab) (char= c #\Return) (char= c #\Linefeed)))
+
+(defun not-whitespace? (c)
+ (not (whitespace? c)))
+
+(defun string-ws? (str)
+ "Return t if string is all whitespace"
+ (when (stringp str)
+ (null (find-if #'not-whitespace? str))))
+
+
+;;; Output
+
+(unless (boundp '+indent-vector+)
+ (defconstant +indent-vector+
+ (make-array 15 :fill-pointer nil :adjustable nil
+ :initial-contents
+ '(""
+ " "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " "))))
+
+(defmacro indent-spaces (n &optional stream)
+ "Indent n*2 spaces to output stream"
+ (let ((st (gensym)))
+ `(let ((,st ,stream))
+ (unless ,st
+ (setq ,st *standard-output*))
+ (when (plusp ,n)
+ (if (< ,n 10)
+ (princ (aref +indent-vector+ ,n) ,st)
+ (dotimes (i ,n)
+ (declare (fixnum i))
+ (format ,st " ")))))))
+
+(defun print-list (l &optional (output *standard-output*))
+"Print a list to a stream"
+ (if (consp l)
+ (progn
+ (mapcar (lambda (x) (princ x output) (princ #\newline output)) l)
+ t)
+ nil))
+
+(defun print-rows (rows &optional (ostrm *standard-output*))
+"Print a list of list rows to a stream"
+ (dolist (r rows)
+ (mapcar (lambda (a) (princ a ostrm) (princ #\space ostrm)) r)
+ (terpri ostrm)))
+
+
+;;; Symbol functions
+
+(defmacro concat-symbol (&rest args)
+ `(intern (concatenate 'string ,@args)))
+
+(defmacro concat-symbol-pkg (pkg &rest args)
+ `(intern (concatenate 'string ,@args) ,pkg))
+
+
+;;; IO
+
+
+(defstruct buf
+ vec (start -1) (used -1) (new -1) (end -1))
+
+(defun bref (buf n)
+ (svref (buf-vec buf)
+ (mod n (length (buf-vec buf)))))
+
+(defun (setf bref) (val buf n)
+ (setf (svref (buf-vec buf)
+ (mod n (length (buf-vec buf))))
+ val))
+
+(defun new-buf (len)
+ (make-buf :vec (make-array len)))
+
+(defun buf-insert (x b)
+ (setf (bref b (incf (buf-end b))) x))
+
+(defun buf-pop (b)
+ (prog1
+ (bref b (incf (buf-start b)))
+ (setf (buf-used b) (buf-start b)
+ (buf-new b) (buf-end b))))
+
+(defun buf-next (b)
+ (when (< (buf-used b) (buf-new b))
+ (bref b (incf (buf-used b)))))
+
+(defun buf-reset (b)
+ (setf (buf-used b) (buf-start b)
+ (buf-new b) (buf-end b)))
+
+(defun buf-clear (b)
+ (setf (buf-start b) -1 (buf-used b) -1
+ (buf-new b) -1 (buf-end b) -1))
+
+(defun buf-flush (b str)
+ (do ((i (1+ (buf-used b)) (1+ i)))
+ ((> i (buf-end b)))
+ (princ (bref b i) str)))
+
+
+(defun file-subst (old new file1 file2)
+ (with-open-file (in file1 :direction :input)
+ (with-open-file (out file2 :direction :output
+ :if-exists :supersede)
+ (stream-subst old new in out))))
+
+(defun stream-subst (old new in out)
+ (declare (string old new))
+ (let* ((pos 0)
+ (len (length old))
+ (buf (new-buf len))
+ (from-buf nil))
+ (declare (fixnum pos len))
+ (do ((c (read-char in nil :eof)
+ (or (setf from-buf (buf-next buf))
+ (read-char in nil :eof))))
+ ((eql c :eof))
+ (declare (character c))
+ (cond ((char= c (char old pos))
+ (incf pos)
+ (cond ((= pos len) ; 3
+ (princ new out)
+ (setf pos 0)
+ (buf-clear buf))
+ ((not from-buf) ; 2
+ (buf-insert c buf))))
+ ((zerop pos) ; 1
+ (princ c out)
+ (when from-buf
+ (buf-pop buf)
+ (buf-reset buf)))
+ (t ; 4
+ (unless from-buf
+ (buf-insert c buf))
+ (princ (buf-pop buf) out)
+ (buf-reset buf)
+ (setf pos 0))))
+ (buf-flush buf out)))
+
+
+;;; Tree Functions
+
+(defun remove-tree-if (pred tree)
+ "Strip from tree of atoms that satistify predicate"
+ (if (atom tree)
+ (unless (funcall pred tree)
+ tree)
+ (let ((car-strip (remove-tree-if pred (car tree)))
+ (cdr-strip (remove-tree-if pred (cdr tree))))
+ (cond
+ ((and car-strip (atom (cadr tree)) (null cdr-strip))
+ (list car-strip))
+ ((and car-strip cdr-strip)
+ (cons car-strip cdr-strip))
+ (car-strip
+ car-strip)
+ (cdr-strip
+ cdr-strip)))))
+
+(defun find-tree (sym tree)
+ "Finds an atom as a car in tree and returns cdr tree at that positions"
+ (if (or (null tree) (atom tree))
+ nil
+ (if (eql sym (car tree))
+ (cdr tree)
+ (aif (find-tree sym (car tree))
+ it
+ (aif (find-tree sym (cdr tree))
+ it
+ nil)))))
+
+;;; Files
+
+(defun print-file-contents (file &optional (strm *standard-output*))
+ "Opens a reads a file. Returns the contents as a single string"
+ (when (probe-file file)
+ (with-open-file (in file :direction :input)
+ (do ((line (read-line in nil 'eof)
+ (read-line in nil 'eof)))
+ ((eql line 'eof))
+ (format strm "~A~%" line)))))
+
+(defun read-file-to-string (file)
+ "Opens a reads a file. Returns the contents as a single string"
+ (with-output-to-string (out)
+ (with-open-file (in file :direction :input)
+ (do ((line (read-line in nil 'eof)
+ (read-line in nil 'eof)))
+ ((eql line 'eof))
+ (format out "~A~%" line)))))
+
+(defun read-file-to-strings (file)
+ "Opens a reads a file. Returns the contents as a list of strings"
+ (let ((lines '()))
+ (with-open-file (in file :direction :input)
+ (do ((line (read-line in nil 'eof)
+ (read-line in nil 'eof)))
+ ((eql line 'eof))
+ (push line lines)))
+ (nreverse lines)))
+
+
+;; Generalized equal system
+
+(defun generalized-equal (obj1 obj2)
+ (if (not (equal (type-of obj1) (type-of obj2)))
+ (progn
+ (terpri)
+ (describe obj1)
+ (describe obj2)
+ nil)
+ (typecase obj1
+ (double-float
+ (let ((diff (abs (/ (- obj1 obj2) obj1))))
+ (if (> diff (* 10 double-float-epsilon))
+ nil
+ t)))
+ (complex
+ (and (generalized-equal (realpart obj1) (realpart obj2))
+ (generalized-equal (imagpart obj1) (imagpart obj2))))
+ (structure
+ (generalized-equal-fielded-object obj1 obj2))
+ (standard-object
+ (generalized-equal-fielded-object obj1 obj2))
+ (hash-table
+ (generalized-equal-hash-table obj1 obj2)
+ )
+ (function
+ (generalized-equal-function obj1 obj2))
+ (string
+ (string= obj1 obj2))
+ (array
+ (generalized-equal-array obj1 obj2))
+ (t
+ (equal obj1 obj2)))))
+
+
+(defun generalized-equal-function (obj1 obj2)
+ (string= (function-to-string obj1) (function-to-string obj2)))
+
+(defun generalized-equal-array (obj1 obj2)
+ (block test
+ (when (not (= (array-total-size obj1) (array-total-size obj2)))
+ (return-from test nil))
+ (dotimes (i (array-total-size obj1))
+ (unless (generalized-equal (aref obj1 i) (aref obj2 i))
+ (return-from test nil)))
+ (return-from test t)))
+
+(defun generalized-equal-hash-table (obj1 obj2)
+ (block test
+ (when (not (= (hash-table-count obj1) (hash-table-count obj2)))
+ (return-from test nil))
+ (maphash
+ #'(lambda (k v)
+ (multiple-value-bind (value found) (gethash k obj2)
+ (unless (and found (generalized-equal v value))
+ (return-from test nil))))
+ obj1)
+ (return-from test t)))
+
+(defun generalized-equal-fielded-object (obj1 obj2)
+ (block test
+ (when (not (equal (class-of obj1) (class-of obj2)))
+ (return-from test nil))
+ (dolist (field (class-slot-names (class-name (class-of obj1))))
+ (unless (generalized-equal (slot-value obj1 field) (slot-value obj2 field))
+ (return-from test nil)))
+ (return-from test t)))
+
+#+(or allegro lispworks)
+(defun class-slot-names (class-name)
+ "Given a CLASS-NAME, returns a list of the slots in the class."
+ (mapcar #'clos:slot-definition-name
+ (clos:class-slots (find-class class-name))))
+
+#-(or allegro lispworks)
+(defun class-slot-names (class-name)
+ (warn "class-slot-names not supported on this platform"))
+
+
+(defun function-to-string (obj)
+ "Returns the lambda code for a function. Relies on
+Allegro implementation-dependent features."
+ (multiple-value-bind (lambda closurep name) (function-lambda-expression obj)
+ (declare (ignore closurep))
+ (if lambda
+ (format nil "#'~s" lambda)
+ (if name
+ (format nil "#'~s" name)
+ (progn
+ (print obj)
+ (break))))))
+
+
+;;; Formatting functions
+
+(defun pretty-date (year month day &optional (hour 12) (m 0) (s 0))
+ (multiple-value-bind (sec min hr dy mn yr wkday)
+ (decode-universal-time
+ (encode-universal-time s m hour day month year))
+ (values (elt '("Monday" "Tuesday" "Wednesday" "Thursday"
+ "Friday" "Saturday" "Sunday")
+ wkday)
+ (elt '("January" "February" "March" "April" "May" "June"
+ "July" "August" "September" "October" "November"
+ "December")
+ (1- mn))
+ (format nil "~A" dy) (format nil "~A" yr)
+ (format nil "~2,'0D:~2,'0D:~2,'0D" hr min sec))))
+
+
+(defun date-string (ut)
+ (if (typep ut 'integer)
+ (multiple-value-bind (sec min hr day mon year dow daylight-p zone)
+ (decode-universal-time ut)
+ (declare (ignore daylight-p zone))
+ (format nil "~[Mon~;Tue~;Wed~;Thu~;Fri~;Sat~;Sun~], ~
+~d ~[Jan~;Feb~;Mar~;Apr~;May~;Jun~;Jul~;Aug~;Sep~;Oct~;Nov~;Dec~] ~d ~
+~2,'0d:~2,'0d:~2,'0d"
+ dow
+ day
+ (1- mon)
+ year
+ hr min sec))))
+
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: kmrcl.asd
+;;;; Purpose: ASDF system definition for KMRCL package
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Apr 2000
+;;;;
+;;;; $Id: kmrcl.asd,v 1.1 2002/10/06 13:21:47 kevin Exp $
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+#+allegro (require :pxml)
+#+allegro (require :aserve)
+
+(in-package :asdf)
+
+(defsystem :kmrcl
+ :components
+ ((:file "package")
+ (:file "genutils" :depends-on ("package"))
+ (:file "buff-input" :depends-on ("genutils"))
+ (:file "telnet-server" :depends-on ("genutils"))
+ (:file "pipes" :depends-on ("package"))
+ (:file "random" :depends-on ("package"))
+ (:file "cl-symbols" :depends-on ("package"))
+ #+allegro (:file "attrib-class" :depends-on ("package"))
+
+ (:file "web-utils" :depends-on ("package"))
+ (:file "xml-utils" :depends-on ("package"))
+ #+(or allegro lispworks) (:file "ml-class" :depends-on ("package"))
+ #+(or allegro aserve) (:file "web-utils-aserve" :depends-on ("package"))
+ ))
+
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: ml-class.lisp
+;;;; Purpose: Markup Language Metaclass
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Apr 2000
+;;;;
+;;;; This metaclass as functions to classes to allow display
+;;;; in Text, HTML, and XML formats. This includes hyperlinking
+;;;; capability and sub-objects.
+;;;;
+;;;; $Id: ml-class.lisp,v 1.1 2002/10/06 13:21:47 kevin Exp $
+;;;;
+;;;; This file, part of Webutils, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; Webutils users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+(in-package :webutils)
+
+(declaim (optimize (speed 3) (safety 1)))
+
+
+(defclass ml-class (standard-class)
+ ((title :initarg :title :type string :reader ml-std-title
+ :documentation
+"Print Title for class")
+ (fields :initarg :fields :reader ml-std-fields
+ :documentation
+"List of field lists for printing. Format is
+ ((fieldname type optional-formatter) ... )")
+ (subobjects-lists
+ :initarg :subobjects-lists :reader ml-std-subobjects-lists
+ :documentation
+"List of fields that contain a list of subobjects objects.")
+ (ref-fields
+ :initarg :ref-fields :type list :reader ml-std-ref-field
+ :documentation
+ "List of fields that can be referred to by browsers.
+Format is ((field-name field-lookup-func other-link-params) ...)")
+
+ ;;; The remainder of these fields are calculated one time
+ ;;; in finalize-inheritence.
+ (value-func :initform nil :type function :reader ml-std-value-func)
+ (xmlvalue-func :initform nil :type function :reader ml-std-xmlvalue-func)
+ (fmtstr-text :initform nil :type string :reader ml-std-fmtstr-text)
+ (fmtstr-html :initform nil :type string :reader ml-std-fmtstr-html)
+ (fmtstr-xml :initform nil :type string :reader ml-std-fmtstr-xml)
+ (fmtstr-text-labels :initform nil :type string :reader ml-std-fmtstr-text-labels)
+ (fmtstr-html-labels :initform nil :type string :reader ml-std-fmtstr-html-labels)
+ (fmtstr-xml-labels :initform nil :type string :reader ml-std-fmtstr-xml-labels)
+ (fmtstr-html-ref :initform nil :type string :reader ml-std-fmtstr-html-ref)
+ (fmtstr-xml-ref :initform nil :type string :reader ml-std-fmtstr-xml-ref)
+ (fmtstr-html-ref-labels :initform nil :type string :reader ml-std-fmtstr-html-ref-labels)
+ (fmtstr-xml-ref-labels :initform nil :type string :reader ml-std-fmtstr-xml-ref-labels)
+ )
+ (:default-initargs :title nil :fields nil :subobjects-lists nil :ref-fields nil)
+ (:documentation "Metaclass for Markup Language classes."))
+
+
+#+allegro
+(defmethod mop:finalize-inheritance :after ((cl ml-class))
+ (init-ml-class cl))
+
+#+lispworks
+(defmethod clos:finalize-inheritance :after ((cl ml-class))
+ (init-ml-class cl))
+
+#+cmu
+(defmethod pcl:finalize-inheritance :after ((cl ml-class))
+ (init-ml-class cl))
+
+#+lispworks
+(defmethod clos:process-a-class-option ((class ml-class)
+ (name (eql :title))
+ value)
+ (unless value
+ (error "ml-class title must have a value"))
+ (if (null (cdr value))
+ (list name (car value))
+ (list name `',value)))
+
+#+lispworks
+(defmethod clos:process-a-class-option ((class ml-class)
+ (name (eql :fields))
+ value)
+ (unless value
+ (error "ml-class fields must have a value"))
+ (list name `',value))
+
+#+lispworks
+(defmethod clos:process-a-class-option ((class ml-class)
+ (name (eql :ref-fields))
+ value)
+ (unless value
+ (error "ml-class ref-fields must have a value"))
+ (list name `',value))
+
+#+lispworks
+(defmethod clos:process-a-class-option ((class ml-class)
+ (name (eql :subobjects-lists))
+ value)
+ (unless value
+ (error "ml-class subobjects-lists must have a value"))
+ (list name `',value))
+
+;;;; Class initialization function
+
+(defun init-ml-class (cl)
+ (let ((fmtstr-text "")
+ (fmtstr-html "")
+ (fmtstr-xml "")
+ (fmtstr-text-labels "")
+ (fmtstr-html-labels "")
+ (fmtstr-xml-labels "")
+ (fmtstr-html-ref "")
+ (fmtstr-xml-ref "")
+ (fmtstr-html-ref-labels "")
+ (fmtstr-xml-ref-labels "")
+ (first-field t)
+ (value-func '())
+ (xmlvalue-func '())
+ (classname (class-name cl))
+ (ref-fields (slot-value cl 'ref-fields)))
+ (declare (ignore classname))
+ (dolist (f (slot-value cl 'fields))
+ (let ((name (car f))
+ (namestr (symbol-name (car f)))
+ (namestr-lower (string-downcase (symbol-name (car f))))
+ (type (cadr f))
+ (formatter (caddr f))
+ (value-fmt "~a")
+ (plain-value-func nil)
+ html-str xml-str html-label-str xml-label-str)
+
+ (when (or (eql type :integer) (eql type :fixnum))
+ (setq value-fmt "~d"))
+
+ (when (eql type :commainteger)
+ (setq value-fmt "~:d"))
+
+ (when (eql type :boolean)
+ (setq value-fmt "~a"))
+
+ (if first-field
+ (setq first-field nil)
+ (progn
+ (gu:string-append fmtstr-text " ")
+ (gu:string-append fmtstr-html " ")
+ (gu:string-append fmtstr-xml " ")
+ (gu:string-append fmtstr-text-labels " ")
+ (gu:string-append fmtstr-html-labels " ")
+ (gu:string-append fmtstr-xml-labels " ")
+ (gu:string-append fmtstr-html-ref " ")
+ (gu:string-append fmtstr-xml-ref " ")
+ (gu:string-append fmtstr-html-ref-labels " ")
+ (gu:string-append fmtstr-xml-ref-labels " ")))
+
+ (setq html-str value-fmt)
+ (setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "</" namestr-lower ">"))
+ (setq html-label-str (concatenate 'string "<i>" namestr-lower "</i> " value-fmt))
+ (setq xml-label-str (concatenate 'string "<label>" namestr-lower "</label> <" namestr-lower ">" value-fmt "</" namestr-lower ">"))
+
+ (gu:string-append fmtstr-text value-fmt)
+ (gu:string-append fmtstr-html html-str)
+ (gu:string-append fmtstr-xml xml-str)
+ (gu:string-append fmtstr-text-labels namestr-lower " " value-fmt)
+ (gu:string-append fmtstr-html-labels html-label-str)
+ (gu:string-append fmtstr-xml-labels xml-label-str)
+
+ (if (find name ref-fields :key #'car)
+ (progn
+ (gu:string-append fmtstr-html-ref "<~~a>" value-fmt "</~~a>")
+ (gu:string-append fmtstr-xml-ref "<~~a>" value-fmt "</~~a>")
+ (gu:string-append fmtstr-html-ref-labels "<i>" namestr-lower "</i> <~~a>" value-fmt "</~~a>")
+ (gu:string-append fmtstr-xml-ref-labels "<label>" namestr-lower "</label> <~~a>" value-fmt "</~~a>"))
+ (progn
+ (gu:string-append fmtstr-html-ref html-str)
+ (gu:string-append fmtstr-xml-ref xml-str)
+ (gu:string-append fmtstr-html-ref-labels html-label-str)
+ (gu:string-append fmtstr-xml-ref-labels xml-label-str)))
+
+ (if formatter
+ (setq plain-value-func
+ (list `(,formatter (,(gu:concat-symbol-pkg
+ :umlisp namestr) x))))
+ (setq plain-value-func
+ (list `(,(gu:concat-symbol-pkg
+ :umlisp namestr) x))))
+ (setq value-func (append value-func plain-value-func))
+
+ (if (eql type :cdata)
+ (setq xmlvalue-func (append xmlvalue-func (list `(xml-cdata ,@plain-value-func))))
+ (setq xmlvalue-func (append xmlvalue-func plain-value-func)))
+ ))
+
+ (setq value-func `(lambda (x) (values ,@value-func)))
+ (setq value-func (compile nil (eval value-func)))
+ (setq xmlvalue-func `(lambda (x) (values ,@xmlvalue-func)))
+ (setq xmlvalue-func (compile nil (eval xmlvalue-func)))
+
+ (setf (slot-value cl 'fmtstr-text) fmtstr-text)
+ (setf (slot-value cl 'fmtstr-html) fmtstr-html)
+ (setf (slot-value cl 'fmtstr-xml) fmtstr-xml)
+ (setf (slot-value cl 'fmtstr-text-labels) fmtstr-text-labels)
+ (setf (slot-value cl 'fmtstr-html-labels) fmtstr-html-labels)
+ (setf (slot-value cl 'fmtstr-xml-labels) fmtstr-xml-labels)
+ (setf (slot-value cl 'fmtstr-html-ref) fmtstr-html-ref)
+ (setf (slot-value cl 'fmtstr-xml-ref) fmtstr-xml-ref)
+ (setf (slot-value cl 'fmtstr-html-ref-labels) fmtstr-html-ref-labels)
+ (setf (slot-value cl 'fmtstr-xml-ref-labels) fmtstr-xml-ref-labels)
+ (setf (slot-value cl 'value-func) value-func)
+ (setf (slot-value cl 'xmlvalue-func) xmlvalue-func))
+ (values))
+
+
+(defun ml-class-fmtstr-text (obj)
+ (slot-value (class-of obj) 'fmtstr-text))
+
+(defun ml-class-fmtstr-html (obj)
+ (slot-value (class-of obj) 'fmtstr-html))
+
+(defun ml-class-fmtstr-xml (obj)
+ (slot-value (class-of obj) 'fmtstr-xml))
+
+(defun ml-class-fmtstr-text-labels (obj)
+ (slot-value (class-of obj) 'fmtstr-text-labels))
+
+(defun ml-class-fmtstr-html-labels (obj)
+ (slot-value (class-of obj) 'fmtstr-html-labels))
+
+(defun ml-class-fmtstr-xml-labels (obj)
+ (slot-value (class-of obj) 'fmtstr-xml-labels))
+
+(defun ml-class-value-func (obj)
+ (slot-value (class-of obj) 'value-func))
+
+(defun ml-class-xmlvalue-func (obj)
+ (slot-value (class-of obj) 'xmlvalue-func))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defun ml-class-title (obj)
+ (gu:awhen (slot-value (class-of obj) 'title)
+ (if (consp gu:it)
+ (car gu:it)
+ gu:it))))
+
+(defun ml-class-subobjects-lists (obj)
+ (slot-value (class-of obj) 'subobjects-lists))
+
+(defun ml-class-ref-fields (obj)
+ (slot-value (class-of obj) 'ref-fields))
+
+(defun ml-class-fields (obj)
+ (slot-value (class-of obj) 'fields))
+
+(defun ml-class-fmtstr-html-ref (obj)
+ (slot-value (class-of obj) 'fmtstr-html-ref))
+
+(defun ml-class-fmtstr-xml-ref (obj)
+ (slot-value (class-of obj) 'fmtstr-xml-ref))
+
+(defun ml-class-fmtstr-html-ref-labels (obj)
+ (slot-value (class-of obj) 'fmtstr-html-ref-labels))
+
+(defun ml-class-fmtstr-xml-ref-labels (obj)
+ (slot-value (class-of obj) 'fmtstr-xml-ref-labels))
+
+;;; Class name functions
+
+(defmethod ml-class-stdname ((name string))
+ (string-downcase (subseq name :start 1)))
+
+(defmethod ml-class-stdname ((cl standard-object))
+ (string-downcase (subseq (class-name (class-of cl)) :start 1)))
+
+;;;; Generic Print functions
+
+(defparameter *default-textformat* nil)
+(defparameter *default-htmlformat* nil)
+(defparameter *default-htmlrefformat* nil)
+(defparameter *default-xmlformat* nil)
+(defparameter *default-xmlrefformat* nil)
+(defparameter *default-nullformat* nil)
+(defparameter *default-init-format?* nil)
+
+(defun make-format-instance (fmt)
+ (unless *default-init-format?*
+ (setq *default-textformat* (make-instance 'textformat))
+ (setq *default-htmlformat* (make-instance 'htmlformat))
+ (setq *default-htmlrefformat* (make-instance 'htmlrefformat))
+ (setq *default-xmlformat* (make-instance 'xmlformat))
+ (setq *default-xmlrefformat* (make-instance 'xmlrefformat))
+ (setq *default-nullformat* (make-instance 'nullformat))
+ (setq *default-init-format?* t))
+
+ (case fmt
+ (:text *default-textformat*)
+ (:html *default-htmlformat*)
+ (:htmlref *default-htmlrefformat*)
+ (:xml *default-xmlformat*)
+ (:xmlref *default-xmlrefformat*)
+ (:null *default-nullformat*)
+ (otherwise *default-textformat*)))
+
+;;;; Output format classes for print ml-classes
+
+(defclass dataformat ()
+ ((file-start-str :type string :initarg :file-start-str :reader file-start-str)
+ (file-end-str :type string :initarg :file-end-str :reader file-end-str)
+ (list-start-fmtstr :type string :initarg :list-start-fmtstr :reader list-start-fmtstr)
+ (list-start-value-func :type function :initarg :list-start-value-func :reader list-start-value-func)
+ (list-start-indent :initarg :list-start-indent :reader list-start-indent)
+ (list-end-fmtstr :type string :initarg :list-end-fmtstr :reader list-end-fmtstr)
+ (list-end-value-func :type function :initarg :list-end-value-func :reader list-end-value-func)
+ (list-end-indent :initarg :list-end-indent :reader list-end-indent)
+ (obj-start-fmtstr :type string :initarg :obj-start-fmtstr :reader obj-start-fmtstr)
+ (obj-start-value-func :initarg :obj-start-value-func :reader obj-start-value-func)
+ (obj-start-indent :initarg :obj-start-indent :reader obj-start-indent)
+ (obj-end-fmtstr :type string :initarg :obj-end-fmtstr :reader obj-end-fmtstr)
+ (obj-end-value-func :initarg :obj-end-value-func :reader obj-end-value-func)
+ (obj-end-indent :initarg :obj-end-indent :reader obj-end-indent)
+ (obj-data-indent :initarg :obj-data-indent :reader obj-data-indent)
+ (obj-data-fmtstr :initarg :obj-data-fmtstr :reader obj-data-fmtstr)
+ (obj-data-fmtstr-labels :initarg :obj-data-fmtstr-labels :reader obj-data-fmtstr-labels)
+ (obj-data-end-fmtstr :initarg :obj-data-end-fmtstr :reader obj-data-end-fmtstr)
+ (obj-data-value-func :initarg :obj-data-value-func :reader obj-data-value-func)
+ (link-ref :initarg :link-ref :reader link-ref))
+ (:default-initargs :file-start-str nil :file-end-str nil :list-start-fmtstr nil :list-start-value-func nil
+ :list-start-indent nil :list-end-fmtstr nil :list-end-value-func nil :list-end-indent nil
+ :obj-start-fmtstr nil :obj-start-value-func nil :obj-start-indent nil
+ :obj-end-fmtstr nil :obj-end-value-func nil :obj-end-indent nil
+ :obj-data-indent nil :obj-data-fmtstr nil :obj-data-fmtstr-labels nil :obj-data-end-fmtstr nil
+ :obj-data-value-func nil :link-ref nil)
+ (:documentation "Parent for all dataformat objects"))
+
+(defclass binaryformat (dataformat)
+ ())
+
+(defclass nullformat (dataformat)
+ ())
+
+(defun text-list-start-value-func (obj nitems)
+ (values (ml-class-title obj) nitems))
+
+(defclass textformat (dataformat)
+ ()
+ (:default-initargs :list-start-fmtstr "~a~P:~%"
+ :list-start-value-func #'text-list-start-value-func
+ :list-start-indent t
+ :obj-data-indent t
+ :obj-data-fmtstr #'ml-class-fmtstr-text
+ :obj-data-fmtstr-labels #'ml-class-fmtstr-text-labels
+ :obj-data-end-fmtstr "~%"
+ :obj-data-value-func #'ml-class-value-func))
+
+(defclass htmlformat (textformat)
+ ()
+ (:default-initargs :file-start-str "<html><body>~%"
+ :file-end-str "</body><html>~%"
+ :list-start-indent t
+ :list-start-fmtstr "<p><b>~a~P:</b></p><ul>~%"
+ :list-start-value-func #'text-list-start-value-func
+ :list-end-fmtstr "</ul>~%"
+ :list-end-indent t
+ :list-end-value-func #'identity
+ :obj-start-indent t
+ :obj-start-fmtstr "<li>"
+ :obj-start-value-func #'identity
+ :obj-end-indent t
+ :obj-end-fmtstr "</li>~%"
+ :obj-end-value-func #'identity
+ :obj-data-indent t
+ :obj-data-fmtstr #'ml-class-fmtstr-html-labels
+ :obj-data-fmtstr-labels #'ml-class-fmtstr-html-labels
+ :obj-data-value-func #'ml-class-value-func))
+
+(defclass htmlrefformat (htmlformat)
+ ()
+ (:default-initargs :link-ref (make-instance 'html-link-ref)))
+
+(defun class-name-of (obj)
+ (string-downcase (class-name (class-of obj))))
+
+(defun xmlformat-list-end-value-func (x)
+ (format nil "~alist" (string-downcase (class-name (class-of x)))))
+
+(defun xmlformat-list-start-value-func (x nitems)
+ (values (format nil "~alist" (string-downcase (class-name (class-of x)))) (ml-class-title x) nitems))
+
+(defclass xmlformat (textformat)
+ ()
+ (:default-initargs :file-start-str "" ; (gu:std-xml-header)
+ :list-start-indent t
+ :list-start-fmtstr "<~a><title>~a~p:</title> ~%"
+ :list-start-value-func #'xmlformat-list-start-value-func
+ :list-end-indent t
+ :list-end-fmtstr "</~a>~%"
+ :list-end-value-func #'xmlformat-list-end-value-func
+ :obj-start-fmtstr "<~a>"
+ :obj-start-value-func #'class-name-of
+ :obj-start-indent t
+ :obj-end-fmtstr "</~a>~%"
+ :obj-end-value-func #'class-name-of
+ :obj-end-indent nil
+ :obj-data-indent nil
+ :obj-data-fmtstr #'ml-class-fmtstr-xml
+ :obj-data-fmtstr-labels #'ml-class-fmtstr-xml-labels
+ :obj-data-value-func #'ml-class-xmlvalue-func))
+
+(defclass xmlrefformat (xmlformat)
+ ()
+ (:default-initargs :link-ref (make-instance 'xml-link-ref)))
+
+(defclass link-ref ()
+ ((fmtstr :type function :initarg :fmtstr :accessor fmtstr)
+ (fmtstr-labels :type function :initarg :fmtstr-labels :accessor fmtstr-labels)
+ (page-name :type string :initarg :page-name :accessor page-name)
+ (href-head :type string :initarg :href-head :accessor href-head)
+ (href-end :type string :initarg :href-end :accessor href-end)
+ (ampersand :type string :initarg :ampersand :accessor ampersand))
+ (:default-initargs :fmtstr nil
+ :fmtstr-labels nil
+ :page-name "disp-func1"
+ :href-head nil :href-end nil :ampersand nil)
+ (:documentation "Formatting for a linked reference"))
+
+(defclass html-link-ref (link-ref)
+ ()
+ (:default-initargs :fmtstr #'ml-class-fmtstr-html-ref
+ :fmtstr-labels #'ml-class-fmtstr-html-ref-labels
+ :href-head "a href="
+ :href-end "a"
+ :ampersand "&"))
+
+(defclass xml-link-ref (link-ref)
+ ()
+ (:default-initargs :fmtstr #'ml-class-fmtstr-xml-ref
+ :fmtstr-labels #'ml-class-fmtstr-xml-ref-labels
+ :href-head "xmllink xlink:type=\"simple\" xlink:href="
+ :href-end "xmllink"
+ :ampersand "&"))
+
+
+;;; File Start and Ends
+
+(defmethod fmt-file-start ((fmt dataformat) (s stream)))
+
+(defmethod fmt-file-start ((fmt textformat) (s stream))
+ (gu:aif (file-start-str fmt)
+ (format s gu::it)))
+
+(defmethod fmt-file-end ((fmt textformat) (s stream))
+ (gu:aif (file-end-str fmt)
+ (format s gu::it)))
+
+;;; List Start and Ends
+
+(defmethod fmt-list-start (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1))
+ (if (list-start-indent fmt)
+ (gu:indent-spaces indent s))
+ (gu:aif (list-start-fmtstr fmt)
+ (apply #'format s gu::it
+ (multiple-value-list
+ (funcall (list-start-value-func fmt) x num-items)))))
+
+(defmethod fmt-list-end (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1))
+ (declare (ignore num-items))
+ (if (list-end-indent fmt)
+ (gu:indent-spaces indent s))
+ (gu:aif (list-end-fmtstr fmt)
+ (apply #'format s gu::it
+ (multiple-value-list
+ (funcall (list-end-value-func fmt) x)))))
+
+;;; Object Start and Ends
+
+(defmethod fmt-obj-start (x (fmt textformat) (s stream) &optional (indent 0))
+ (if (obj-start-indent fmt)
+ (gu:indent-spaces indent s))
+ (gu:aif (obj-start-fmtstr fmt)
+ (apply #'format s gu::it
+ (multiple-value-list
+ (funcall (obj-start-value-func fmt) x)))))
+
+(defmethod fmt-obj-end (x (fmt textformat) (s stream) &optional (indent 0))
+ (if (obj-end-indent fmt)
+ (gu:indent-spaces indent s))
+ (gu:aif (obj-end-fmtstr fmt)
+ (apply #'format s gu::it
+ (multiple-value-list
+ (funcall (obj-end-value-func fmt) x)))))
+
+;;; Object Data
+
+(defmethod make-link-start (obj (ref link-ref) fieldname fieldfunc fieldvalue refvars)
+ (declare (ignore obj fieldname))
+ (format nil "~a\"~a?func=~a~akey=~a~a\""
+ (href-head ref) (make-url (page-name ref)) fieldfunc
+ (ampersand ref) fieldvalue
+ (if refvars
+ (let ((varstr ""))
+ (dolist (var refvars)
+ (gu:string-append varstr (format nil "~a~a=~a"
+ (ampersand ref) (car var) (cadr var))))
+ varstr)
+ "")))
+
+(defmethod make-link-end (obj (ref link-ref) fieldname)
+ (declare (ignore obj fieldname))
+ (format nil "~a" (href-end ref))
+ )
+
+(defmethod fmt-obj-data (x (fmt textformat) s
+ &optional (indent 0) (label nil) (refvars nil))
+ (if (obj-data-indent fmt)
+ (gu:indent-spaces indent s))
+ (if (link-ref fmt)
+ (fmt-obj-data-with-ref x fmt s label refvars)
+ (fmt-obj-data-plain x fmt s label))
+ (gu:aif (obj-data-end-fmtstr fmt)
+ (format s gu::it)))
+
+(defmethod fmt-obj-data-plain (x (fmt textformat) s label)
+ (if label
+ (apply #'format s
+ (funcall (obj-data-fmtstr-labels fmt) x)
+ (multiple-value-list
+ (funcall (funcall (obj-data-value-func fmt) x) x)))
+ (apply #'format s (funcall (obj-data-fmtstr fmt) x)
+ (multiple-value-list
+ (funcall (funcall (obj-data-value-func fmt) x) x)))))
+
+(defmethod fmt-obj-data-with-ref (x (fmt textformat) s label refvars)
+ (let ((refstr (make-ref-data-str x fmt label))
+ (refvalues nil)
+ (field-values
+ (multiple-value-list
+ (funcall (funcall (obj-data-value-func fmt) x) x))))
+
+ ;; make list of reference link fields for printing to refstr template
+ (dolist (field (ml-class-ref-fields x))
+ (let ((link-start
+ (make-link-start x (link-ref fmt) (car field) (cadr field)
+ (nth (position (car field) (ml-class-fields x) :key #'car) field-values)
+ (append (caddr field) refvars)))
+ (link-end (make-link-end x (link-ref fmt) (car field))))
+ (push link-start refvalues)
+ (push link-end refvalues)))
+ (setq refvalues (nreverse refvalues))
+
+ (apply #'format s refstr refvalues)))
+
+(defmethod obj-data (x)
+ "Returns the objects data as a string. Used by common-graphics outline function"
+ (let ((fmt (make-format-instance :text)))
+ (apply #'format nil (funcall (obj-data-fmtstr fmt) x)
+ (multiple-value-list
+ (funcall (funcall (obj-data-value-func fmt) x) x)))))
+
+(defmethod make-ref-data-str (x (fmt textformat) &optional (label nil))
+ "Return fmt string for that contains ~a slots for reference link start and end"
+ (unless (link-ref fmt)
+ (error "fmt does not contain a link-ref"))
+ (let ((refstr
+ (if label
+ (apply #'format nil (funcall (fmtstr-labels (link-ref fmt)) x)
+ (multiple-value-list
+ (funcall (funcall (obj-data-value-func fmt) x) x)))
+ (apply #'format nil (funcall (fmtstr (link-ref fmt)) x)
+ (multiple-value-list (funcall (funcall (obj-data-value-func fmt) x) x))))))
+ refstr))
+
+;;; Display method for objects
+
+
+(defmethod load-all-subobjects (objs)
+ "Load all subobjects if they have not already been loaded."
+ (when objs
+ (let ((objlist (gu:mklist objs)))
+ (dolist (obj objlist)
+ (gu:awhen (ml-class-subobjects-lists obj) ;; access list of functions
+ (dolist (child-obj gu::it) ;; for each child function
+ (gu:awhen (funcall (car child-obj) obj)
+ (load-all-subobjects gu:it))))))
+ objs))
+
+(defmethod output-ml-class (objs (fmt dataformat) (strm stream)
+ &optional (label nil) (english-only-function nil)
+ (indent 0) (subobjects nil) (refvars nil))
+ "Display a single or list of ml-class instances and their subobjects"
+ (when objs
+ (setq objs (gu:mklist objs))
+ (let ((nobjs (length objs)))
+ (fmt-list-start (car objs) fmt strm indent nobjs)
+ (dolist (obj objs)
+ (unless (and english-only-function (not (funcall english-only-function obj)))
+ (fmt-obj-start obj fmt strm indent)
+ (fmt-obj-data obj fmt strm (1+ indent) label refvars)
+ (if subobjects
+ (gu:awhen (ml-class-subobjects-lists obj) ;; access list of functions
+ (dolist (child-obj gu::it) ;; for each child function
+ (gu:awhen (funcall (car child-obj) obj) ;; access set of child objects
+ (output-ml-class gu::it fmt strm label
+ english-only-function
+ (1+ indent) subobjects refvars)))))
+ (fmt-obj-end obj fmt strm indent)))
+ (fmt-list-end (car objs) fmt strm indent nobjs))
+ t))
+
+(defun display-ml-class (objs &key (os *standard-output*) (format :text)
+ (label nil) (english-only-function nil) (subobjects nil)
+ (file-wrapper t) (refvars nil))
+ "EXPORTED Function: displays a ml-class. Simplies call to output-ml-class"
+ (let ((fmt (make-format-instance format)))
+ (if file-wrapper
+ (fmt-file-start fmt os))
+ (when objs
+ (output-ml-class objs fmt os label english-only-function 0 subobjects refvars))
+ (if file-wrapper
+ (fmt-file-end fmt os)))
+ objs)
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: package.lisp
+;;;; Purpose: Package definition for kmrcl package
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Apr 2000
+;;;;
+;;;; $Id: package.lisp,v 1.1 2002/10/06 13:21:47 kevin Exp $
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+
+(in-package :cl-user)
+
+(defpackage #:kmrcl
+ (:nicknames :k)
+ (:use :common-lisp
+ #+(or aserve allegro) :net.html.generator
+ #+(or aserve allegro) :net.aserve
+ #+allegro :net.xml.parser
+ )
+ (:export #:bind-if
+ #:bind-when
+ #:aif
+ #:awhen
+ #:awhile
+ #:aand
+ #:acond
+ #:alambda
+ #:it
+ #:mac
+ #:show
+ #:show-variables
+ #:show-functions
+ #:ensure-integer
+ #:mklist
+ #:filter
+ #:memo-proc
+ #:memoize
+ #:defun-memo
+ #:_f
+ #:compose
+ #:until
+ #:while
+ #:for
+ #:mapappend
+ #:mapcar-append-string
+ #:mapcar2-append-string
+ #:delimited-string-to-list
+ #:list-to-delimited-string
+ #:string-append
+ #:count-string-words
+ #:substitute-string-for-char
+ #:string-trim-last-character
+ #:string-hash
+ #:string-not-null?
+ #:whitespace?
+ #:not-whitespace?
+ #:string-ws?
+ #:string-invert
+ #:indent-spaces
+ #:print-list
+ #:print-rows
+ #:concat-symbol
+ #:concat-symbol-pkg
+ #:file-subst
+ #:stream-subst
+ #:remove-tree-if
+ #:find-tree
+ #:print-file-contents
+ #:read-file-to-string
+ #:read-file-to-strings
+ #:add-sql-quotes
+ #:escape-backslashes
+ #:remove-keyword
+ #:remove-keywords
+ #:in
+ #:mean
+ #:with-gensyms
+
+ ;; From attrib-class.lisp
+ #:attributes-class
+ #:slot-attribute
+
+ #:generalized-equal
+
+ ;; From buffered input
+
+ #:make-fields-buffer
+ #:read-buffered-fields
+
+ #:pretty-date
+ #:date-string
+
+ ;; From random.lisp
+ #:seed-random-generator
+ #:random-choice
+
+
+ ;; From pipes.lisp
+ #:+empty-pipe+
+ #:make-pipe
+ #:pipe-tail
+ #:pipe-head
+ #:pipe-elt
+ #:enumerate
+ #:pipe-display
+ #:pipe-force
+ #:pipe-filter
+ #:pipe-map
+ #:pipe-map-filtering
+ #:pipe-append
+ #:pipe-mappend
+ #:pipe-mappend-filtering
+
+ ;; From telnet-server.lisp
+ #:start-telnet-server
+
+ ;; From web-utils
+ #:std-xml-header
+ #:xml-cdata
+
+ ;; From web-utils-allegro
+ #:cgi-var
+ #:print-http
+ #:princ-http
+ #:base-url!
+ #:make-url
+ #:with-tag
+ #:with-tag-attribute
+ #:princ-http-with-color
+ #:princ-http-with-size
+ #:with-link
+ #:home-link
+ #:head
+ #:with-xml-page
+ #:with-trans-page
+ #:wrap-with-xml
+ #:parse-xml-no-ws
+ #:positions-xml-tag-contents
+ #:xml-tag-contents
+ #:encode-query
+
+ ;; From ml-class.lisp
+ #:ml-class
+ #:ml-class-title
+ #:load-all-subobjects
+ #:display-ml-class
+ ))
+
+
+
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: pipes.lisp
+;;;; Purpose: Pipes based on ideas from Norvig's PAIP book
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Apr 2000
+;;;;
+;;;; $Id: pipes.lisp,v 1.1 2002/10/06 13:21:47 kevin Exp $
+;;;;
+;;;; This file, part of Genutils, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; Genutils users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+(in-package :genutils)
+
+(defmacro make-pipe (head tail)
+ "create a pipe by eval'ing head and delaying tail."
+ `(cons ,head #'(lambda () ,tail)))
+
+(defun pipe-tail (pipe)
+ "return tail of pipe or list, and destructively update
+ the tail if it is a function."
+ ;; This assumes that pipes will never contain functions as values...
+ (if (functionp (rest pipe))
+ (setf (rest pipe) (funcall (rest pipe)))
+ (rest pipe)))
+
+(defun pipe-head (pipe) (first pipe))
+
+(defun pipe-elt (pipe i)
+ "ith element of pipe, 0 based."
+ (if (= i 0) (pipe-head pipe)
+ (pipe-elt (pipe-tail pipe) (- i 1))))
+
+(defconstant +empty-pipe+ nil)
+
+(defun enumerate (pipe &key count key (result pipe))
+ "go through all or count elements of pipe,
+ possibly applying the key function. "
+ (if (or (eq pipe +empty-pipe+) (eql count 0))
+ result
+ (progn
+ (unless (null key) (funcall key (pipe-head pipe)))
+ (enumerate (pipe-tail pipe)
+ :count (if count (1- count))
+ :key key
+ :result result))))
+
+(defun pipe-display (pipe &optional count)
+ (enumerate pipe :count count))
+
+(defun pipe-force (pipe)
+ (enumerate pipe))
+
+;;; incorrect version-- as in Norvig.
+;(defun filter-pipe (predicate pipe)
+; "keep only items in (non-null) pipe satisfying predicate"
+; (if (funcall predicate (head pipe))
+; (make-pipe (head pipe) (filter-pipe predicate (tail pipe)))
+; (pipe-filter predicate (tail pipe))))
+
+
+(defun pipe-filter (predicate pipe)
+ "keep only items in (non-null) pipe satisfying predicate"
+ (if (eq pipe +empty-pipe+)
+ +empty-pipe+
+ (let ((head (pipe-head pipe))
+ (tail (pipe-tail pipe)))
+ (if (funcall predicate head)
+ (make-pipe head (pipe-filter predicate tail))
+ (pipe-filter predicate tail)))))
+
+
+(defun pipe-map (fn pipe)
+ "Map fn over pipe, delaying all but the first fn call,
+ collecting res<ults"
+ (if (eq pipe +empty-pipe+)
+ +empty-pipe+
+ (make-pipe (funcall fn (pipe-head pipe))
+ (pipe-map fn (pipe-tail pipe)))))
+
+
+(defun pipe-map-filtering (fn pipe &optional filter-test)
+ "Map fn over pipe, delaying all but the first fn call,
+ collecting results"
+ (if (eq pipe +empty-pipe+)
+ +empty-pipe+
+ (let* ((head (pipe-head pipe))
+ (tail (pipe-tail pipe))
+ (result (funcall fn head)))
+ (if (or (and filter-test (funcall filter-test result))
+ result)
+ (make-pipe result (pipe-map-filtering fn tail filter-test))
+ (pipe-map-filtering fn tail filter-test)))))
+
+
+(defun pipe-append (pipex pipey)
+ "return a pipe that appends two pipes"
+ (if (eq pipex +empty-pipe+)
+ pipey
+ (make-pipe (pipe-head pipex)
+ (pipe-append (pipe-tail pipex) pipey))))
+
+(defun pipe-mappend (fn pipe)
+ "lazily map fn over pipe, appending results"
+ (if (eq pipe +empty-pipe+)
+ +empty-pipe+
+ (let ((x (funcall fn (pipe-head pipe))))
+ (make-pipe (pipe-head x)
+ (pipe-append (pipe-tail x)
+ (pipe-mappend fn (pipe-tail pipe)))))))
+
+(defun pipe-mappend-filtering (fn pipe &optional filter-test)
+ "Map fn over pipe, delaying all but the first fn call,
+ appending results, filtering along the way"
+ (if (eq pipe +empty-pipe+)
+ +empty-pipe+
+ (let* ((head (pipe-head pipe))
+ (tail (pipe-tail pipe))
+ (result (funcall fn head)))
+ (if (or (and filter-test (funcall filter-test result))
+ result)
+ (make-pipe (pipe-head result)
+ (pipe-append (pipe-tail result)
+ (pipe-mappend-filtering fn tail filter-test)))
+ (pipe-mappend-filtering fn tail filter-test)))))
+
+
+
+#||
+;; Applications
+
+(defun integers (&optional (start 0) end)
+ "a pipe of integers from START to END."
+ (if (or (null end) (<= start end))
+ (make-pipe start (integers (+ start 1) end))
+ nil))
+
+(defun fibgen (a b)
+ (make-pipe a (fibgen b (+ a b))))
+
+(defun fibs ()
+ (fibgen 0 1))
+
+
+(defun divisible? (x y)
+ (zerop (rem x y)))
+
+
+(defun no-sevens ()
+ (pipe-filter #'(lambda (x) (not (divisible? x 7))) (integers)))
+
+
+(defun sieve (stream)
+ (make-pipe
+ (pipe-head stream)
+ (sieve (pipe-filter
+ #'(lambda (x)
+ (not (divisible? x (pipe-head stream))))
+ (pipe-tail stream)))))
+
+(defun primes ()
+ (sieve (integers 2)))
+
+
+;; Pi
+
+(defun scale-pipe (factor pipe)
+ (pipe-map #'(lambda (x) (* x factor)) pipe))
+
+(defun sum-pipe (sum s)
+ (make-pipe sum
+ (sum-pipe (+ sum (pipe-head s))
+ (pipe-tail s))))
+
+(defun partial-sums (s)
+ (make-pipe (pipe-head s) (sum-pipe 0 s)))
+
+(defun pi-summands (n)
+ (make-pipe (/ 1d0 n)
+ (pipe-map #'- (pi-summands (+ n 2)))))
+
+(defun pi-stream ()
+ (scale-pipe 4d0 (partial-sums (pi-summands 1))))
+
+(defun square (x)
+ (* x x))
+
+(defun euler-transform (s)
+ (let ((s0 (pipe-elt s 0))
+ (s1 (pipe-elt s 1))
+ (s2 (pipe-elt s 2)))
+ (if (and s0 s1 s2)
+ (if (eql s1 s2) ;;; series has converged
+ +empty-pipe+
+ (make-pipe (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (pipe-tail s))))
+ +empty-pipe+)))
+
+
+(defun ln2-summands (n)
+ (pipe-map (/ 1d0 n)
+ (pipe-map #'- (ln2-summands (1+ n)))))
+
+(defun ln2-stream ()
+ (partial-sums (ln2-summands 1)))
+
+(defun make-tableau (transform s)
+ (make-pipe s
+ (make-tableau transform
+ (funcall transform s))))
+
+(defun accelerated-sequence (transform s)
+ (pipe-map #'pipe-head
+ (make-tableau transform s)))
+
+
+ (pipe-display (pi-stream) 10)
+ (pipe-display (euler-transform (pi-stream)) 10)
+ (pipe-display (accelerated-sequence #'euler-transform (pi-stream)) 10)
+
+||#
+
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: random.lisp
+;;;; Purpose: Random number functions for GENUTILS package
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Apr 2000
+;;;;
+;;;; $Id: random.lisp,v 1.1 2002/10/06 13:21:47 kevin Exp $
+;;;;
+;;;; This file, part of Genutils, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; Genutils users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+(in-package :genutils)
+
+(defun seed-random-generator ()
+ "Evaluate a random number of items"
+ (let ((randfile (make-pathname
+ :directory '(:absolute "dev")
+ :name "urandom")))
+ (setf *random-state* (make-random-state t))
+ (if (probe-file randfile)
+ (with-open-file
+ (rfs randfile :element-type 'unsigned-byte)
+ (let*
+ ;; ((seed (char-code (read-char rfs))))
+ ((seed (read-byte rfs)))
+ ;;(format t "Randomizing!~%")
+ (loop
+ for item from 1 to seed
+ do (loop
+ for it from 0 to (+ (read-byte rfs) 5)
+ do (random 65536))))))))
+
+
+(defmacro random-choice (&rest exprs)
+ `(case (random ,(length exprs))
+ ,@(let ((key -1))
+ (mapcar #'(lambda (expr)
+ `(,(incf key) ,expr))
+ exprs))))
+
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: telnet-server.lisp
+;;;; Purpose: A telnet server
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Apr 2000
+;;;;
+;;;; $Id: telnet-server.lisp,v 1.1 2002/10/06 13:21:47 kevin Exp $
+;;;;
+;;;; This file, part of Genutils, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; Genutils users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+(in-package :genutils)
+
+(defvar *default-telnet-server-port* 4000)
+
+#+allegro
+(defun start-telnet-server (&optional (port *default-telnet-server-port*))
+ (let ((passive (socket:make-socket :connect :passive
+ :local-host "127.1"
+ :local-port port
+ :reuse-address t)))
+ (mp:process-run-function
+ "telnet-listener"
+ #'(lambda (pass)
+ (let ((count 0))
+ (loop
+ (let ((con (socket:accept-connection pass)))
+ (mp:process-run-function
+ (format nil "tel~d" (incf count))
+ #'(lambda (con)
+ (unwind-protect
+ (tpl::start-interactive-top-level
+ con
+ #'tpl::top-level-read-eval-print-loop
+ nil)
+ (ignore-errors (close con :abort t))))
+ con)))))
+ passive)))
+
+#+lispworks
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require "comm"))
+
+#+lispworks
+(defun sts2 (&optional (port *default-telnet-server-port*))
+ (comm:start-up-server :service port :function 'comm::make-stream-and-run-listener))
+
+#+lispworks
+(defun make-telnet-stream (handle)
+ (let ((stream (make-instance 'comm:socket-stream
+ :socket handle
+ :direction :io
+ :element-type
+ 'base-char)))
+ (mp:process-run-function
+ (format nil "telnet-session ~D" handle)
+ '()
+ 'telnet-on-stream stream)))
+
+(defun read-telnet-line (stream)
+ (string-right-trim '(#\newline #\linefeed #\return #\space #\tab #\backspace) (read-line stream nil nil)))
+
+(defun print-prompt (stream)
+ (format stream "~&~A> " (package-name *package*))
+ (force-output stream))
+
+(defvar *telnet-password* "ksec")
+
+(defun telnet-on-stream (stream)
+ (unwind-protect
+ (progn
+ (let ((password (read-telnet-line stream)))
+ (unless (and (stringp password)
+ (string= password *telnet-password*))
+ (return-from telnet-on-stream)))
+ (print-prompt stream)
+ (loop for line = (read-telnet-line stream)
+ while line
+ do
+ (ignore-errors
+ (format stream "~S" (eval (read-from-string line))))
+ (force-output stream)
+ (print-prompt stream)))
+ (close stream)))
+
+#+lispworks
+(defun start-telnet-server (&optional (port *default-telnet-server-port*))
+ (comm:start-up-server :service port
+ :process-name (format nil "telnet-~d" port)
+ :function 'gu::make-telnet-stream))
+
+
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: web-utils-aserve.lisp
+;;;; Purpose: Web utilities based on aserve functions
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Apr 2000
+;;;;
+;;;; $Id: web-utils-aserve.lisp,v 1.1 2002/10/06 13:21:47 kevin Exp $
+;;;;
+;;;; This file, part of Webutils, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; Webutils users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+
+
+(in-package :webutils)
+(declaim (optimize (speed 3) (safety 1)))
+
+
+;;; AllegroServe interaction functions
+
+(defun cgi-var (var req)
+ "Look CGI variable in AllegroServe association list"
+ (cdr (assoc var (net.aserve:request-query req) :test #'equal)))
+
+(defun princ-http (s)
+ (princ s *html-stream*))
+
+(defun print-http (s)
+ (format *html-stream* "~a~%" s))
+
+
+;;; Tag functions
+
+(defmacro with-tag (tag &rest body)
+ "Outputs to http tag and executes body"
+ `(prog1
+ (progn
+ (princ-http (format nil "<~a>" ,tag))
+ ,@body)
+ (princ-http (format nil "</~a>" ,tag))))
+
+(defmacro with-tag-attribute (tag attribute &rest body)
+ "Outputs to http tag + attribute and executes body"
+ `(prog1
+ (progn
+ (princ-http (format nil "<~a ~a>" ,tag ,attribute))
+ ,@body)
+ (princ-http (format nil "</~a>" ,tag))))
+
+(defun princ-http-with-color (text color)
+ (with-tag-attribute "font" (format nil "color=\"~a\"" color)
+ (princ-http text)))
+
+(defun princ-http-with-size (text size)
+ (with-tag-attribute "font" (format nil "size=\"~a\"" size)
+ (princ-http text)))
+
+(defmacro with-link ((href xml linktype) &rest body)
+ (declare (ignore linktype))
+; (format *html-stream* "Return to <cui2 xml:href=\"qstr\">Home</cui2>")
+; (format *html-stream* "Return to <go xml:link=\"simple\" show=\"replace\" href=\"qstr/\">Home</go>")
+ `(if ,xml
+ (progn
+ (princ-http "<elem xlink:type=\"simple\" xlink:href=\"")
+ (princ-http ,href)
+ (princ-http "\">")
+ ,@body
+ (princ-http "</elem>"))
+ (progn
+ (princ-http "<a href=\"")
+ (princ-http ,href)
+ (princ-http "\">")
+ ,@body
+ (princ-http "</a>"))))
+
+(defun home-link (&key (xml nil) (vars nil))
+ (princ-http "<font size=\"-1\">Return to ")
+ (with-link ((make-url "index.html" :vars vars) xml "homelink")
+ (princ-http "Browser Home"))
+ (princ-http "</font><p></p>"))
+
+(defun head (title-str)
+ (net.html.generator:html
+ (:head
+ "<LINK rel=\"stylesheet\" href=\"http://www.med-info.com/main.css\" type=\"text/css\">"
+ (:title (:princ-safe title-str)))))
+
+
+
+;;; Page wrappers
+
+(defmacro with-xml-page (title &rest body)
+ `(prog1
+ (progn
+ (net.html.generator:html
+ (princ-http (std-xml-header))
+ (princ-http "<pagedata xmlns:xlink=\"http://www.w3.org/1999/xlink\" xmlns:html=\"http://www.w3.org/TR/REC-html40\">"))
+ (with-tag "pagetitle" (princ-http ,title))
+ ,@body)
+ (princ-http "</pagedata>")))
+
+(defmacro with-trans-page (title &rest body)
+ `(prog1
+ (progn
+ (print-http "<?xml version=\"1.0\" standalone=\"yes\"?>")
+ (print-http "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"")
+ (print-http " \"http://www.w3c.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")
+ (print-http "")
+ (print-http "<html xmlns=\"http://www.w3.org/1999/xhtml\">")
+ (head ,title)
+ (print-http "<body bgcolor=\"#FFFFFF\">")
+ (prog1
+ ,@body
+ (print-http "</body>")))
+ (print-http "</html>")))
+
+
+;;; URL Encoding
+
+(defun encode-query (query)
+ "Escape [] from net.aserve's query-to-form-urlencoded"
+ (substitute-string-for-char
+ (substitute-string-for-char
+ (substitute-string-for-char
+ (substitute #\+ #\space query)
+ #\[ "%5B")
+ #\] "%5D")
+ #\" "%22"))
+
+
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: web-utils.lisp
+;;;; Purpose: Basic web utility functions
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Apr 2000
+;;;;
+;;;; $Id: web-utils.lisp,v 1.1 2002/10/06 13:21:47 kevin Exp $
+;;;;
+;;;; This file, part of Webutils, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; Webutils users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+(in-package :webutils)
+(declaim (optimize (speed 3) (safety 1)))
+
+
+;;; HTML/XML constants
+
+(defvar *std-xml-header*
+ (format nil
+ "<?xml version=\"1.0\" ?>~%<?xml-stylesheet type=\"text/css\" href=\"/umlsclass.css\" ?>~%~%"))
+
+(defun std-xml-header ()
+ *std-xml-header*)
+
+;;; URL Functions
+
+(defvar *base-url* "")
+(defun base-url! (url)
+ (setq *base-url* url))
+
+(defun make-url (page-name &key (base-dir *base-url*) (vars nil))
+ (concatenate 'string base-dir page-name
+ (if vars
+ (string-trim-last-character
+ (concatenate 'string "?"
+ (mapcar-append-string
+ #'(lambda (var)
+ (when (and (car var) (cadr var))
+ (concatenate 'string
+ (car var) "=" (cadr var) "&")))
+ vars)))
+ "")))
+
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: xml-utils.lisp
+;;;; Purpose: XML utilities
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Apr 2000
+;;;;
+;;;; $Id: xml-utils.lisp,v 1.1 2002/10/06 13:21:47 kevin Exp $
+;;;;
+;;;; This file, part of Webutils, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; Webutils users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+(in-package :webutils)
+
+(declaim (optimize (speed 3) (safety 1)))
+
+
+(defun wrap-with-xml (str entity)
+ "Returns string of xml header along with entity tag start/end with str contents"
+ (format nil "<?xml version=\"1.0\" standalone=\"yes\"?>~%~%<~a>~%~a~%</~a>~%"
+ str entity entity))
+
+
+;;; XML Extraction Functions
+
+#+allegro
+(defun parse-xml-no-ws (str)
+ "Return list structure of XML string with removing whitespace strings"
+ (remove-tree-if #'string-ws? (parse-xml str)))
+
+(defun positions-xml-tag-contents (tag xmlstr &optional (start-xmlstr 0) (end-xmlstr nil))
+ "Returns three values: the start and end positions of contents between
+ the xml tags and the position following the close of the end tag."
+ (let ((done nil)
+ (pos start-xmlstr)
+ (taglen (length tag))
+ (startpos nil)
+ (endpos nil)
+ (nextpos nil))
+ (unless end-xmlstr
+ (setq end-xmlstr (length xmlstr)))
+ (while (not done)
+ (let ((bracketpos (position #\< xmlstr :start pos :end end-xmlstr)))
+ (if bracketpos
+ (let* ((starttag (1+ bracketpos))
+ (endtag (+ starttag taglen)))
+ (if (string= tag xmlstr :start2 starttag :end2 endtag)
+ (let* ((char-after-tag (char xmlstr endtag)))
+ (declare (character char-after-tag))
+ (if (or (char= #\> char-after-tag) (char= #\space char-after-tag))
+ (progn
+ (if (char= #\> char-after-tag)
+ (setq startpos (1+ endtag))
+ (setq startpos (1+ (position #\> xmlstr :start (1+ endtag)))))
+ (setq endpos (search (format nil "</~a>" tag) xmlstr
+ :start2 startpos :end2 end-xmlstr))
+ (setq done t)
+ (if (and startpos endpos)
+ (progn
+ (setq nextpos (+ endpos taglen 3))
+ (setq pos nextpos))
+ (setf startpos nil
+ endpos nil)))
+ (setq pos (1+ endtag))))
+ (setq pos (1+ starttag)))
+ (when (> pos end-xmlstr)
+ (setq done t)))
+ (setq done t))))
+ (values startpos endpos nextpos)))
+
+
+(defun xml-tag-contents (tag xmlstr &optional (start-xmlstr 0) (end-xmlstr nil))
+ "Returns two values: the string between XML start and end tag
+and position of character following end tag."
+ (multiple-value-bind
+ (startpos endpos nextpos)
+ (positions-xml-tag-contents tag xmlstr start-xmlstr end-xmlstr)
+ (if (and startpos endpos)
+ (values (subseq xmlstr startpos endpos) nextpos)
+ (values nil nil))))
+