;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: io.lisp,v 1.6 2003/05/09 09:35:04 kevin Exp $
+;;;; $Id: io.lisp,v 1.7 2003/06/06 21:59:29 kevin Exp $
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
-(in-package :kmrcl)
+(in-package #:kmrcl)
(defun print-file-contents (file &optional (strm *standard-output*))
"Opens a reads a file. Returns the contents as a single string"
:if-exists :supersede)
(stream-subst old new in out))))
-(defmacro print-n-chars (char n stream)
- (let ((i (gensym)))
- `(dotimes (,i ,n)
- (declare (fixnum ,i))
- (write-char ,char ,stream))))
+(defun print-n-chars (char n stream)
+ (declare (fixnum n)
+ (optimize (speed 3) (safety 0) (space 0)))
+ (do ((i 0 (1+ i)))
+ ((= i n) char)
+ (declare (fixnum i))
+ (write-char char stream)))
(defun indent-spaces (n &optional (stream *standard-output*))
"Indent n*2 spaces to output stream"
;;;; Author: Kevin M. Rosenberg
;;;; Date Started: Apr 2003
;;;;
-;;;; $Id: kmrcl-tests.asd,v 1.2 2003/05/08 19:19:08 kevin Exp $
+;;;; $Id: kmrcl-tests.asd,v 1.3 2003/06/06 21:59:29 kevin Exp $
;;;; *************************************************************************
(defpackage #:kmrcl-tests-system
:components
((:file "tests")))
-(defmethod perform ((o test-op) (c (eql (find-system :kmrcl-tests))))
+(defmethod perform ((o test-op) (c (eql (find-system 'kmrcl-tests))))
(or (funcall (intern (symbol-name '#:do-tests)
(find-package '#:regression-test)))
(error "test-op failed")))
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: kmrcl.asd,v 1.29 2003/04/29 04:56:58 kevin Exp $
+;;;; $Id: kmrcl.asd,v 1.30 2003/06/06 21:59:29 kevin Exp $
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
+(in-package #:cl-user)
(defpackage #:kmrcl-system (:use #:asdf #:cl))
(in-package #:kmrcl-system)
#+(or allegro lispworks sbcl cmu scl)
(defmethod perform ((o test-op) (c (eql (find-system :kmrcl))))
- (oos 'load-op 'kmrcl-tests)
- (oos 'test-op 'kmrcl-tests))
+ (operate 'load-op 'kmrcl-tests)
+ (operate 'test-op 'kmrcl-tests))
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: lists.lisp,v 1.4 2003/05/11 21:51:43 kevin Exp $
+;;;; $Id: lists.lisp,v 1.5 2003/06/06 21:59:29 kevin Exp $
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
-(in-package :kmrcl)
-
+(in-package #:kmrcl)
(defun mklist (obj)
"Make into list if atom"
(let ((acc nil))
(dolist (x lst (nreverse acc))
(let ((val (funcall fn x)))
- (if val (push val acc))))))
+ (when val (push val acc))))))
(defun appendnew (l1 l2)
"Append two lists, filtering out elem from second list that are already in first list"
(let ((results (car list)))
(dolist (elem (cdr list) results)
(setq results (append results elem)))))
-
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: macros.lisp,v 1.1 2003/04/28 23:51:59 kevin Exp $
+;;;; $Id: macros.lisp,v 1.2 2003/06/06 21:59:29 kevin Exp $
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
-(in-package :kmrcl)
+(in-package #:kmrcl)
(defmacro let-when ((var test-form) &body body)
`(let ((,var ,test-form))
`(labels ((self ,parms ,@body))
#'self))
-
(defmacro aif2 (test &optional then else)
(let ((win (gensym)))
`(multiple-value-bind (it ,win) ,test
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Nov 2002
;;;;
-;;;; $Id: math.lisp,v 1.3 2003/04/28 23:51:59 kevin Exp $
+;;;; $Id: math.lisp,v 1.4 2003/06/06 21:59:29 kevin Exp $
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
;;;; *************************************************************************
-(in-package :kmrcl)
+(in-package #:kmrcl)
(defun deriv (f dx)
#'(lambda (x)
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: package.lisp,v 1.33 2003/05/26 21:43:05 kevin Exp $
+;;;; $Id: package.lisp,v 1.34 2003/06/06 21:59:30 kevin Exp $
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-
-(in-package :cl-user)
+(in-package #:cl-user)
(defpackage #:kmrcl
- (:nicknames :kl)
- (:use :common-lisp)
+ (:nicknames #:kl)
+ (:use #:cl)
(:export
#:ensure-integer
#:mklist
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: random.lisp,v 1.3 2002/10/10 16:23:48 kevin Exp $
+;;;; $Id: random.lisp,v 1.4 2003/06/06 21:59:30 kevin Exp $
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
-(in-package :kmrcl)
+(in-package #:kmrcl)
(defun seed-random-generator ()
"Evaluate a random number of items"
+(in-package #:cl-user)
(defpackage #:run-tests (:use #:cl))
(in-package #:run-tests)
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: strings.lisp,v 1.34 2003/05/26 21:43:05 kevin Exp $
+;;;; $Id: strings.lisp,v 1.35 2003/06/06 21:59:30 kevin Exp $
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
;;;; *************************************************************************
-(in-package :kmrcl)
+(in-package #:kmrcl)
;;; Strings
(setq pos (1+ end))))
-(defun list-to-delimited-string (list &optional (separator #\space))
- (format nil (format nil "~~{~~A~~^~A~~}" separator) list))
+(defun list-to-delimited-string (list &optional (separator " "))
+ (format nil (concatenate 'string "~{~A~^" (string separator) "~}") list))
(defun string-invert (str)
"Invert case of a string"
vec))
(defun concat-separated-strings (separator &rest lists)
- (format nil (format nil "~~{~~A~~^~A~~}" separator) (append-sublists lists)))
+ (format nil (concatenate 'string "~{~A~^" (string separator) "~}")
+ (append-sublists lists)))
(defun only-null-list-elements-p (lst)
(or (null lst) (every #'null lst)))
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: symbols.lisp,v 1.1 2003/04/28 23:51:59 kevin Exp $
+;;;; $Id: symbols.lisp,v 1.2 2003/06/06 21:59:30 kevin Exp $
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
-(in-package :kmrcl)
+(in-package #:kmrcl)
(defun cl-symbols ()
(append (cl-variables) (cl-functions)))
;;;; Author: Kevin M. Rosenberg
;;;; Date Started: Apr 2003
;;;;
-;;;; $Id: tests.lisp,v 1.14 2003/05/11 21:51:44 kevin Exp $
+;;;; $Id: tests.lisp,v 1.15 2003/06/06 21:59:30 kevin Exp $
;;;;
;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
;;;;
;;;; *************************************************************************
+(in-package #:cl)
(defpackage #:kmrcl-tests
(:use #:kmrcl #:cl #:rtest))
(in-package #:kmrcl-tests)
(rem-all-tests)
-
(deftest str.0 (substitute-chars-strings "" nil) "")
(deftest str.1 (substitute-chars-strings "abcd" nil) "abcd")
(deftest str.2 (substitute-chars-strings "abcd" nil) "abcd")
(deftest str.8 (escape-xml-string "abcd") "abcd")
(deftest str.9 (escape-xml-string "ab&cd") "ab&cd")
(deftest str.10 (escape-xml-string "ab&cd<") "ab&cd<")
-(deftest str.11 (escape-xml-string "ab&c><") "ab&c><")
(deftest str.12 (string-trim-last-character "") "")
(deftest str.13 (string-trim-last-character "a") "")
(deftest str.14 (string-trim-last-character "ab") "a")
(deftest css.4 (concat-separated-strings "|" '("ab" "cd") nil) "ab|cd")
(deftest css.5 (concat-separated-strings "|" '("ab" "cd") nil '("ef")) "ab|cd|ef")
-(deftest f.1 (filter #'(lambda (x) (when (oddp x) x))
- '(0 1 2 3 4 5 6 7 8 9)) (1 3 5 7 9))
+(deftest f.1 (filter #'(lambda (x) (when (oddp x) (* x x)))
+ '(0 1 2 3 4 5 6 7 8 9)) (1 9 25 49 81))
(deftest an.1 (appendnew '(a b c d) '(c c e f)) (a b c d e f))
+
+(deftest pxml.1
+ (xml-tag-contents "tag1" "<tag>Test</tag>")
+ nil nil)
+
+(deftest pxml.1o
+ (kmrcl::xml-tag-contents-old "tag1" "<tag>Test</tag>")
+ nil nil)
+
+;;; MOP Testing
+
(eval-when (:compile-toplevel :load-toplevel :execute)
(when (find-package '#:kmr-mop)
(pushnew :kmrtest-mop cl:*features*)))
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: web-utils.lisp,v 1.9 2002/10/18 05:14:49 kevin Exp $
+;;;; $Id: web-utils.lisp,v 1.10 2003/06/06 21:59:30 kevin Exp $
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
-(in-package :kmrcl)
-(declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))
+(in-package #:kmrcl)
;;; HTML/XML constants
amp (car var) "=" (cadr var))))
(rest vars))))
""))))
+
+(defun make-url-new (page-name &key (base-dir *base-url*) (format :html)
+ (vars nil))
+ (let ((amp (ecase format
+ (:html "&")
+ ((:xml :ie-xml) "&"))))
+ (concatenate 'string
+ base-dir page-name
+ (if vars
+ (let ((first-var (first vars)))
+ (concatenate 'string
+ "?" (car first-var) "=" (cadr first-var)
+ (mapcar-append-string
+ #'(lambda (var)
+ (when (and (car var) (cadr var))
+ (concatenate 'string
+ amp (car var) "=" (cadr var))))
+ (rest vars))))
+ ""))))
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: xml-utils.lisp,v 1.7 2003/05/26 21:43:05 kevin Exp $
+;;;; $Id: xml-utils.lisp,v 1.8 2003/06/06 21:59:30 kevin Exp $
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
-(in-package :kmrcl)
-(declaim (optimize (speed 3) (safety 2) (compilation-speed 0) (debug 3)))
+(in-package #:kmrcl)
(defun wrap-with-xml (str entity)
(remove-tree-if #'string-ws? (parse-xml str)))
|#
-(defun positions-xml-tag-contents (tag xmlstr &optional (start-xmlstr 0) (end-xmlstr nil))
+(defun positions-xml-tag-contents-old (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)
(setq done t))))
(values startpos endpos nextpos)))
+(defun find-start-tag (tag taglen xmlstr start-pos end-xmlstr)
+ (let ((bracketpos (position-char #\< xmlstr start-pos end-xmlstr)))
+ (when bracketpos
+ (let* ((starttag (1+ bracketpos))
+ (endtag (+ starttag taglen)))
+ (if (and (< endtag end-xmlstr)
+ (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-char #\> xmlstr (1+ endtag) end-xmlstr))))
+ ))))))))
+
+(defun positions-xml-tag-contents (tag xmlstr &optional (start-xmlstr 0)
+ (end-xmlstr (length xmlstr)))
+ "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))
+ (while (not done)
+ (let ((bracketpos (position-char #\< xmlstr pos end-xmlstr)))
+ (unless bracketpos
+ (return-from positions-xml-tag-contents
+ (values nil nil nil)))
+ (let* ((starttag (1+ bracketpos))
+ (endtag (+ starttag taglen)))
+ (if (and (< endtag end-xmlstr)
+ (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-char #\> xmlstr (1+ endtag) end-xmlstr))))
+ (setq endpos (search (format nil "</~a>" tag) xmlstr
+ :start2 startpos :end2 end-xmlstr))
+ (if (and startpos endpos)
+ (progn
+ (setq nextpos (+ endpos taglen 3))
+ (setq pos nextpos))
+ (setf startpos nil
+ endpos nil))
+ (setq done t))
+ (setq pos (1+ endtag))))
+ (setq pos (1+ starttag)))
+ (when (> pos end-xmlstr)
+ (setq done t))))))
+ (values startpos endpos nextpos)))
+
+
+(defun xml-tag-contents-old (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-old tag xmlstr start-xmlstr end-xmlstr)
+ (if (and startpos endpos)
+ (values (subseq xmlstr startpos endpos) nextpos)
+ (values nil nil))))
(defun xml-tag-contents (tag xmlstr &optional (start-xmlstr 0) (end-xmlstr nil))
"Returns two values: the string between XML start and end tag
(concatenate 'string "<![CDATA[" str "]]>"))
(defun write-xml-cdata (str s)
- (declare (simple-string str) (optimize (speed 3) (safety 0)))
- (do* ((len (length str))
- (i 0 (1+ i)))
- ((= i len) str)
+ (declare (simple-string str) (optimize (speed 3) (safety 0) (space 0)))
+ (do ((len (length str))
+ (i 0 (1+ i)))
+ ((= i len) str)
(declare (fixnum i len))
(let ((c (schar str i)))
(case c
projects / kmrcl.git / commitdiff