projects
/
kmrcl.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
r10994: Automated commit for kmrcl debian-version-1.88-1
[kmrcl.git]
/
strings.lisp
diff --git
a/strings.lisp
b/strings.lisp
index 533bf013a5c663fba805486f07927344f7f39afd..d5bfa07a4b7c35e2baa47d3f513666c8d8dfe492 100644
(file)
--- a/
strings.lisp
+++ b/
strings.lisp
@@
-9,7
+9,7
@@
;;;;
;;;; $Id$
;;;;
;;;;
;;;; $Id$
;;;;
-;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of KMRCL, is Copyright (c) 2002
-2006
by Kevin M. Rosenberg
;;;;
;;;; KMRCL users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
;;;;
;;;; KMRCL users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
@@
-61,7
+61,7
@@
(declare (fixnum i))
(when (char/= char (schar string i)) (return i))))
(declare (fixnum i))
(when (char/= char (schar string i)) (return i))))
-(defun delimited-string-to-list (string &optional (separator #\space)
+(defun delimited-string-to-list (string &optional (separator #\space)
skip-terminal)
"split a string with delimiter"
(declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0))
skip-terminal)
"split a string with delimiter"
(declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0))
@@
-106,7
+106,7
@@
(defun escape-backslashes (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)
+(defun substitute-string-for-char (procstr match-char subst-str)
"Substitutes a string for a single matching character of a string"
(substitute-chars-strings procstr (list (cons match-char subst-str))))
"Substitutes a string for a single matching character of a string"
(substitute-chars-strings procstr (list (cons match-char subst-str))))
@@
-157,7
+157,7
@@
#+allegro #\%space
#+lispworks #\No-Break-Space))
#+allegro #\%space
#+lispworks #\No-Break-Space))
-(defun is-char-whitespace (c)
+(defun is-char-whitespace (c)
(declare (character c) (optimize (speed 3) (safety 0)))
(or (char= c #\Space) (char= c #\Tab) (char= c #\Return)
(char= c #\Linefeed)
(declare (character c) (optimize (speed 3) (safety 0)))
(or (char= c #\Space) (char= c #\Tab) (char= c #\Return)
(char= c #\Linefeed)
@@
-227,17
+227,20
@@
list of characters and replacement strings."
(defun make-usb8-array (len)
(make-array len :element-type '(unsigned-byte 8)))
(defun make-usb8-array (len)
(make-array len :element-type '(unsigned-byte 8)))
-(defun usb8-array-to-string (vec)
- (declare (type (simple-array (unsigned-byte 8) (*)) vec))
- (let* ((len (length vec))
+(defun usb8-array-to-string (vec &key (start 0) end)
+ (declare (type (simple-array (unsigned-byte 8) (*)) vec)
+ (fixnum start))
+ (unless end
+ (setq end (length vec)))
+ (let* ((len (- end start))
(str (make-string len)))
(declare (fixnum len)
(simple-string str)
(str (make-string len)))
(declare (fixnum len)
(simple-string str)
- (optimize (speed 3)))
+ (optimize (speed 3)
(safety 0)
))
(do ((i 0 (1+ i)))
((= i len) str)
(declare (fixnum i))
(do ((i 0 (1+ i)))
((= i len) str)
(declare (fixnum i))
- (setf (schar str i) (code-char (aref vec
i
))))))
+ (setf (schar str i) (code-char (aref vec
(the fixnum (+ i start))
))))))
(defun string-to-usb8-array (str)
(declare (simple-string str))
(defun string-to-usb8-array (str)
(declare (simple-string str))
@@
-350,7
+353,7
@@
Leading zeros are present."
(type (or fixnum null) end))
(push (subseq str pos end) output)
(setq pos (+ end substr-len))))
(type (or fixnum null) end))
(push (subseq str pos end) output)
(setq pos (+ end substr-len))))
-
+
(defun string-to-list-skip-delimiter (str &optional (delim #\space))
"Return a list of strings, delimited by spaces, skipping spaces."
(declare (simple-string str)
(defun string-to-list-skip-delimiter (str &optional (delim #\space))
"Return a list of strings, delimited by spaces, skipping spaces."
(declare (simple-string str)
@@
-413,20
+416,26
@@
for characters in a string"
(declare (type (integer 0 15) n))
(schar +hex-chars+ n))
(declare (type (integer 0 15) n))
(schar +hex-chars+ n))
-(defconstant +char-code-lower-a+ (char-code #\a))
-(defconstant +char-code-upper-a+ (char-code #\A))
-(defconstant +char-code-0+ (char-code #\0))
+(defconstant
*
+char-code-lower-a+ (char-code #\a))
+(defconstant
*
+char-code-upper-a+ (char-code #\A))
+(defconstant
*
+char-code-0+ (char-code #\0))
(declaim (type fixnum +char-code-0+ +char-code-upper-a+
+char-code-0))
(defun charhex (ch)
"convert hex character to decimal"
(let ((code (char-code (char-upcase ch))))
(declaim (type fixnum +char-code-0+ +char-code-upper-a+
+char-code-0))
(defun charhex (ch)
"convert hex character to decimal"
(let ((code (char-code (char-upcase ch))))
- (declare (fixnum ch))
+ (declare (fixnum ch))
(if (>= code +char-code-upper-a+)
(+ 10 (- code +char-code-upper-a+))
(- code +char-code-0+))))
(if (>= code +char-code-upper-a+)
(+ 10 (- code +char-code-upper-a+))
(- code +char-code-0+))))
+(defun binary-sequence-to-hex-string (seq)
+ (let ((list (etypecase seq
+ (list seq)
+ (sequence (map 'list #'identity seq)))))
+ (string-downcase (format nil "~{~2,'0X~}" list))))
+
(defun encode-uri-string (query)
"Escape non-alphanumeric characters for URI fields"
(declare (simple-string query)
(defun encode-uri-string (query)
"Escape non-alphanumeric characters for URI fields"
(declare (simple-string query)
@@
-478,7
+487,7
@@
for characters in a string"
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar +unambiguous-charset+
"abcdefghjkmnpqrstuvwxyz123456789ABCDEFGHJKLMNPQSRTUVWXYZ")
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar +unambiguous-charset+
"abcdefghjkmnpqrstuvwxyz123456789ABCDEFGHJKLMNPQSRTUVWXYZ")
- (defconstant +unambiguous-length+ (length +unambiguous-charset+)))
+ (defconstant
*
+unambiguous-length+ (length +unambiguous-charset+)))
(defun random-char (&optional (set :lower-alpha))
(ecase set
(defun random-char (&optional (set :lower-alpha))
(ecase set
@@
-498,7
+507,7
@@
for characters in a string"
(if (>= n 26)
(code-char (+ +char-code-upper-a+ (- n 26)))
(code-char (+ +char-code-lower-a+ n)))))))
(if (>= n 26)
(code-char (+ +char-code-upper-a+ (- n 26)))
(code-char (+ +char-code-lower-a+ n)))))))
-
+
(defun random-string (&key (length 10) (set :lower-alpha))
"Returns a random lower-case string."
(defun random-string (&key (length 10) (set :lower-alpha))
"Returns a random lower-case string."
@@
-549,7
+558,7
@@
for characters in a string"
(length ending)))))
(return-from string-strip-ending
(subseq str 0 (- len (length ending))))))))
(length ending)))))
(return-from string-strip-ending
(subseq str 0 (- len (length ending))))))))
-
+
(defun string-maybe-shorten (str maxlen)
(string-elide str maxlen :end))
(defun string-maybe-shorten (str maxlen)
(string-elide str maxlen :end))
@@
-566,7
+575,7
@@
for characters in a string"
((eq position :middle)
(multiple-value-bind (mid remain) (truncate maxlen 2)
(let ((end1 (- mid 1))
((eq position :middle)
(multiple-value-bind (mid remain) (truncate maxlen 2)
(let ((end1 (- mid 1))
- (start2 (- len (- mid 2) remain)))
+ (start2 (- len (- mid 2) remain)))
(concatenate 'string (subseq str 0 end1) "..." (subseq str start2)))))
((or (eq position :end) t)
(concatenate 'string (subseq str 0 (- maxlen 3)) "...")))))
(concatenate 'string (subseq str 0 end1) "..." (subseq str start2)))))
((or (eq position :end) t)
(concatenate 'string (subseq str 0 (- maxlen 3)) "...")))))
@@
-591,7
+600,7
@@
for characters in a string"
(flet ((is-sep (char) (member char whitespace :test #'char=)))
(let ((tokens nil))
(do* ((token-start
(flet ((is-sep (char) (member char whitespace :test #'char=)))
(let ((tokens nil))
(do* ((token-start
- (position-if-not #'is-sep string)
+ (position-if-not #'is-sep string)
(when token-end
(position-if-not #'is-sep string :start (1+ token-end))))
(token-end
(when token-end
(position-if-not #'is-sep string :start (1+ token-end))))
(token-end
@@
-606,13
+615,13
@@
for characters in a string"
"Separates a string at any non-alphanumeric chararacter"
(declare (simple-string string)
(optimize (speed 3) (safety 0)))
"Separates a string at any non-alphanumeric chararacter"
(declare (simple-string string)
(optimize (speed 3) (safety 0)))
- (flet ((is-sep (char)
+ (flet ((is-sep (char)
(declare (character char))
(and (non-alphanumericp char)
(not (char= #\_ char)))))
(let ((tokens nil))
(do* ((token-start
(declare (character char))
(and (non-alphanumericp char)
(not (char= #\_ char)))))
(let ((tokens nil))
(do* ((token-start
- (position-if-not #'is-sep string)
+ (position-if-not #'is-sep string)
(when token-end
(position-if-not #'is-sep string :start (1+ token-end))))
(token-end
(when token-end
(position-if-not #'is-sep string :start (1+ token-end))))
(token-end
@@
-627,7
+636,7
@@
for characters in a string"
(defun trim-non-alphanumeric (word)
"Strip non-alphanumeric characters from beginning and end of a word."
(declare (simple-string word)
(defun trim-non-alphanumeric (word)
"Strip non-alphanumeric characters from beginning and end of a word."
(declare (simple-string word)
- (optimize (speed 3) (safety 0) (s
iz
e 0)))
+ (optimize (speed 3) (safety 0) (s
pac
e 0)))
(let* ((start 0)
(len (length word))
(end len))
(let* ((start 0)
(len (length word))
(end len))
@@
-647,7
+656,6
@@
for characters in a string"
(subseq word start end)
word)))
(subseq word start end)
word)))
-
(defun collapse-whitespace (s)
"Convert multiple whitespace characters to a single space character."
(defun collapse-whitespace (s)
"Convert multiple whitespace characters to a single space character."