From: Kevin M. Rosenberg Date: Sun, 6 Oct 2002 13:24:24 +0000 (+0000) Subject: r2948: *** empty log message *** X-Git-Tag: v1.96~342 X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=commitdiff_plain;h=5e5cc3c20a925d8af5de153a118fdaf0792dd7e2 r2948: *** empty log message *** --- 5e5cc3c20a925d8af5de153a118fdaf0792dd7e2 diff --git a/attrib-class.lisp b/attrib-class.lisp new file mode 100644 index 0000000..4d88e66 --- /dev/null +++ b/attrib-class.lisp @@ -0,0 +1,124 @@ +;;;; -*- 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)) + +||# diff --git a/buff-input.lisp b/buff-input.lisp new file mode 100644 index 0000000..fe3f311 --- /dev/null +++ b/buff-input.lisp @@ -0,0 +1,177 @@ +;;;; -*- 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))))))) + diff --git a/cl-symbols.lisp b/cl-symbols.lisp new file mode 100644 index 0000000..3da0a0a --- /dev/null +++ b/cl-symbols.lisp @@ -0,0 +1,43 @@ +;;;; -*- 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))) diff --git a/debian/changelog b/debian/changelog new file mode 100644 index 0000000..0ede4eb --- /dev/null +++ b/debian/changelog @@ -0,0 +1,6 @@ +cl-kmrcl (1.0-1) unstable; urgency=low + + * Initial Release. + + -- Kevin M. Rosenberg Sat, 5 Oct 2002 13:19:33 -0600 + diff --git a/debian/control b/debian/control new file mode 100644 index 0000000..fd7763d --- /dev/null +++ b/debian/control @@ -0,0 +1,15 @@ +Source: cl-kmrcl +Section: devel +Priority: optional +Maintainer: Kevin M. Rosenberg +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. + diff --git a/debian/copyright b/debian/copyright new file mode 100644 index 0000000..f0dbd2f --- /dev/null +++ b/debian/copyright @@ -0,0 +1,15 @@ +This package was debianized by Kevin M. Rosenberg on +Sat, 5 Oct 2002 13:19:33 -0600. + +It was downloaded from ftp://kmrcl.b9.com + +Upstream Author: Kevin M. Rosenberg + +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. + diff --git a/debian/postinst b/debian/postinst new file mode 100755 index 0000000..a10eaba --- /dev/null +++ b/debian/postinst @@ -0,0 +1,46 @@ +#! /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: +# * `configure' +# * `abort-upgrade' +# * `abort-remove' `in-favour' +# +# * `abort-deconfigure' `in-favour' +# `removing' +# +# 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 diff --git a/debian/prerm b/debian/prerm new file mode 100755 index 0000000..1c05eea --- /dev/null +++ b/debian/prerm @@ -0,0 +1,42 @@ +#! /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: +# * `remove' +# * `upgrade' +# * `failed-upgrade' +# * `remove' `in-favour' +# * `deconfigure' `in-favour' +# `removing' +# +# 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 + + diff --git a/debian/rules b/debian/rules new file mode 100755 index 0000000..fa61826 --- /dev/null +++ b/debian/rules @@ -0,0 +1,82 @@ +#!/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 + diff --git a/genutils.lisp b/genutils.lisp new file mode 100644 index 0000000..e35f23d --- /dev/null +++ b/genutils.lisp @@ -0,0 +1,752 @@ +;;;; -*- 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)))) + diff --git a/kmrcl.asd b/kmrcl.asd new file mode 100644 index 0000000..04124bc --- /dev/null +++ b/kmrcl.asd @@ -0,0 +1,39 @@ +;;;; -*- 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")) + )) + diff --git a/ml-class.lisp b/ml-class.lisp new file mode 100644 index 0000000..cfe2ab7 --- /dev/null +++ b/ml-class.lisp @@ -0,0 +1,625 @@ +;;;; -*- 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 "")) + (setq html-label-str (concatenate 'string "" namestr-lower " " value-fmt)) + (setq xml-label-str (concatenate 'string " <" namestr-lower ">" value-fmt "")) + + (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 "") + (gu:string-append fmtstr-xml-ref "<~~a>" value-fmt "") + (gu:string-append fmtstr-html-ref-labels "" namestr-lower " <~~a>" value-fmt "") + (gu:string-append fmtstr-xml-ref-labels " <~~a>" value-fmt "")) + (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 "~%" + :file-end-str "~%" + :list-start-indent t + :list-start-fmtstr "

~a~P:

    ~%" + :list-start-value-func #'text-list-start-value-func + :list-end-fmtstr "
~%" + :list-end-indent t + :list-end-value-func #'identity + :obj-start-indent t + :obj-start-fmtstr "
  • " + :obj-start-value-func #'identity + :obj-end-indent t + :obj-end-fmtstr "
    • ~%" + :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>~a~p: ~%" + :list-start-value-func #'xmlformat-list-start-value-func + :list-end-indent t + :list-end-fmtstr "~%" + :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 "~%" + :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) diff --git a/package.lisp b/package.lisp new file mode 100644 index 0000000..fb96460 --- /dev/null +++ b/package.lisp @@ -0,0 +1,159 @@ +;;;; -*- 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 + )) + + + diff --git a/pipes.lisp b/pipes.lisp new file mode 100644 index 0000000..b97ff07 --- /dev/null +++ b/pipes.lisp @@ -0,0 +1,228 @@ +;;;; -*- 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 " (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)) + + diff --git a/web-utils-aserve.lisp b/web-utils-aserve.lisp new file mode 100644 index 0000000..92a89bd --- /dev/null +++ b/web-utils-aserve.lisp @@ -0,0 +1,135 @@ +;;;; -*- 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 "" ,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 "" ,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 Home") +; (format *html-stream* "Return to Home") + `(if ,xml + (progn + (princ-http "") + ,@body + (princ-http "")) + (progn + (princ-http "") + ,@body + (princ-http "")))) + +(defun home-link (&key (xml nil) (vars nil)) + (princ-http "Return to ") + (with-link ((make-url "index.html" :vars vars) xml "homelink") + (princ-http "Browser Home")) + (princ-http "

    ")) + +(defun head (title-str) + (net.html.generator:html + (:head + "" + (: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 "")) + (with-tag "pagetitle" (princ-http ,title)) + ,@body) + (princ-http ""))) + +(defmacro with-trans-page (title &rest body) + `(prog1 + (progn + (print-http "") + (print-http "") + (print-http "") + (print-http "") + (head ,title) + (print-http "") + (prog1 + ,@body + (print-http ""))) + (print-http ""))) + + +;;; 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")) + + diff --git a/web-utils.lisp b/web-utils.lisp new file mode 100644 index 0000000..c6b9cc8 --- /dev/null +++ b/web-utils.lisp @@ -0,0 +1,49 @@ +;;;; -*- 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 + "~%~%~%")) + +(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))) + ""))) + diff --git a/xml-utils.lisp b/xml-utils.lisp new file mode 100644 index 0000000..bf3b4de --- /dev/null +++ b/xml-utils.lisp @@ -0,0 +1,86 @@ +;;;; -*- 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 "~%~%<~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 "" 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)))) +