r10990: 27 Jul 2006 Kevin Rosenberg <kevin@rosenberg.net>

        * Version 1.88
        * strings.lisp, package.lisp: Add binary-sequence-to-hex-string

diff --git a/ChangeLog b/ChangeLog
index 81bee4febc3e434da54d7ee7f7a34d1ecae0dafc..b7d4445c96c78fd457b9d2f9632f14ee65d4b4dd 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,7 @@
+27 Jul 2006  Kevin Rosenberg <kevin@rosenberg.net>
+       * Version 1.88
+       * strings.lisp, package.lisp: Add binary-sequence-to-hex-string
+       

 26 Jul 2006  Kevin Rosenberg <kevin@rosenberg.net>
        * Version 1.87
        * proceeses.lisp, sockets.lisp: Apply patch from Travis Cross
 26 Jul 2006  Kevin Rosenberg <kevin@rosenberg.net>
        * Version 1.87
        * proceeses.lisp, sockets.lisp: Apply patch from Travis Cross

diff --git a/debian/changelog b/debian/changelog
index 089893d926e4e163454c194aa245e50dfcf27917..82db43fbeb5a94c921b6d696705f07a774aecba8 100644 (file)
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+cl-kmrcl (1.88-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr@debian.org>  Thu, 27 Jul 2006 11:03:55 -0600
+

 cl-kmrcl (1.87-1) unstable; urgency=low
 
   * New upstream
 cl-kmrcl (1.87-1) unstable; urgency=low
 
   * New upstream

diff --git a/package.lisp b/package.lisp
index 58c01720af41e8a9b1855c38a39b4865daa9dcb5..f4d42ff5f4c21b1fbc334bc0502fb3fae0ce9b97 100644 (file)
--- a/package.lisp
+++ b/package.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


@@ -73,7 +73,8 @@
    #:collapse-whitespace
    #:string->list
    #:trim-non-alphanumeric
    #:collapse-whitespace
    #:string->list
    #:trim-non-alphanumeric

-   
+   #:binary-sequence-to-hex-string
+

    ;; io.lisp
    #:indent-spaces
    #:indent-html-spaces
    ;; io.lisp
    #:indent-spaces
    #:indent-html-spaces


@@ -107,7 +108,7 @@
    #:zone
    #:day-of-month
    #:day-of-week
    #:zone
    #:day-of-month
    #:day-of-week

-   #:+datetime-number-strings+   
+   #:+datetime-number-strings+

    #:utc-offset
    #:copy-binary-stream
 
    #:utc-offset
    #:copy-binary-stream
 


@@ -137,10 +138,10 @@
    #:get-plist
    #:flatten
    #:unique-slot-values
    #:get-plist
    #:flatten
    #:unique-slot-values

-   
+

    ;; seq.lisp
    #:nsubseq
    ;; seq.lisp
    #:nsubseq

-   
+

    ;; math.lisp
    #:ensure-integer
    #:histogram
    ;; math.lisp
    #:ensure-integer
    #:histogram


@@ -173,7 +174,7 @@
    #:ppmx
    #:defconstant*
    #:defvar-unbound
    #:ppmx
    #:defconstant*
    #:defvar-unbound

-   
+

    ;; files.lisp
    #:print-file-contents
    #:read-stream-to-string
    ;; files.lisp
    #:print-file-contents
    #:read-stream-to-string


@@ -181,7 +182,7 @@
    #:read-file-to-usb8-array
    #:read-stream-to-strings
    #:read-file-to-strings
    #:read-file-to-usb8-array
    #:read-stream-to-strings
    #:read-file-to-strings

-   
+

    ;; strings.lisp
    #:string-append
    #:count-string-words
    ;; strings.lisp
    #:string-append
    #:count-string-words


@@ -205,11 +206,11 @@
    #:print-separated-strings
    #:lex-string
    #:split-alphanumeric-string
    #:print-separated-strings
    #:lex-string
    #:split-alphanumeric-string

-   
+

    ;; strmatch.lisp
    #:score-multiword-match
    #:multiword-match
    ;; strmatch.lisp
    #:score-multiword-match
    #:multiword-match

-   
+

    ;; symbols.lisp
    #:ensure-keyword
    #:ensure-keyword-upcase
    ;; symbols.lisp
    #:ensure-keyword
    #:ensure-keyword-upcase


@@ -219,7 +220,7 @@
    #:show
    #:show-variables
    #:show-functions
    #:show
    #:show-variables
    #:show-functions

-   
+

    ;; From attrib-class.lisp
    #:attributes-class
    #:slot-attribute
    ;; From attrib-class.lisp
    #:attributes-class
    #:slot-attribute


@@ -228,10 +229,10 @@
    #:generalized-equal
 
    ;; From buffered input
    #:generalized-equal
 
    ;; From buffered input

-   
+

    #:make-fields-buffer
    #:read-buffered-fields
    #:make-fields-buffer
    #:read-buffered-fields

-   
+

    ;; From datetime.lisp
    #:pretty-date
    #:date-string
    ;; From datetime.lisp
    #:pretty-date
    #:date-string


@@ -239,15 +240,15 @@
    #:print-seconds
    #:posix-time-to-utime
    #:utime-to-posix-time
    #:print-seconds
    #:posix-time-to-utime
    #:utime-to-posix-time

-   
+

    ;; From random.lisp
    #:seed-random-generator
    #:random-choice
    ;; From random.lisp
    #:seed-random-generator
    #:random-choice

-   
+

    ;; From repl.lisp
    #:make-repl
    #:init/repl
    ;; From repl.lisp
    #:make-repl
    #:init/repl

-   
+

    ;; From web-utils
    #:*base-url*
    #:base-url!
    ;; From web-utils
    #:*base-url*
    #:base-url!


@@ -258,14 +259,14 @@
    #:user-agent-ie-p
    #:decode-uri-query-string
    #:split-uri-query-string
    #:user-agent-ie-p
    #:decode-uri-query-string
    #:split-uri-query-string

-   
+

    ;; From xml-utils
    #:sgml-header-stream
    #:xml-tag-contents
    #:positions-xml-tag-contents
    #:cdata-string
    #:write-cdata
    ;; From xml-utils
    #:sgml-header-stream
    #:xml-tag-contents
    #:positions-xml-tag-contents
    #:cdata-string
    #:write-cdata

-   
+

    ;; From console
    #:*console-msgs*
    #:cmsg
    ;; From console
    #:*console-msgs*
    #:cmsg


@@ -283,12 +284,12 @@
    ;; sockets.lisp
    #:make-active-socket
    #:close-active-socket
    ;; sockets.lisp
    #:make-active-socket
    #:close-active-socket

-   
+

    ;; listener.lisp
    #:init/listener
    #:stop-all/listener
    #:listener
    ;; listener.lisp
    #:init/listener
    #:stop-all/listener
    #:listener

-   
+

    ;; fformat.lisp
    #:fformat
 
    ;; fformat.lisp
    #:fformat
 

diff --git a/strings.lisp b/strings.lisp
index fbb130caad55b5d4442653f43d1d57290354bd4a..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)


@@ -353,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)


@@ -425,11 +425,17 @@ for characters in a string"
 (defun charhex (ch)
   "convert hex character to decimal"
   (let ((code (char-code (char-upcase ch))))
 (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)


@@ -501,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."


@@ -552,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))


@@ -569,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)) "...")))))


@@ -594,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


@@ -609,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


@@ -650,7 +656,7 @@ 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."
   (declare (simple-string s)
 (defun collapse-whitespace (s)
   "Convert multiple whitespace characters to a single space character."
   (declare (simple-string s)

diff --git a/tests.lisp b/tests.lisp
index e149575ba02cb992b29efc7aee3600f4f164b67b..d78aba3f890c5fbbe445f61e86bb075a73cae23f 100644 (file)
--- a/tests.lisp
+++ b/tests.lisp
@@ -9,7 +9,7 @@
 ;;;;
 ;;;; $Id$
 ;;;;
 ;;;;
 ;;;; $Id$
 ;;;;

-;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
+;;;; This file is Copyright (c) 2000-2006 by Kevin M. Rosenberg

 ;;;;
 ;;;; *************************************************************************
 
 ;;;;
 ;;;; *************************************************************************
 


@@ -64,6 +64,22 @@
 (deftest :sdstl.4 (string-delimited-string-to-list "ab|cd|ef" "ab")
   ("" "|cd|ef"))
 
 (deftest :sdstl.4 (string-delimited-string-to-list "ab|cd|ef" "ab")
   ("" "|cd|ef"))
 

+(deftest :hexstr.1 (binary-sequence-to-hex-string ())
+  "")
+
+(deftest :hexstr.2 (binary-sequence-to-hex-string #())
+  "")
+
+(deftest :hexstr.3 (binary-sequence-to-hex-string #(165))
+  "a5"
+)
+
+(deftest :hexstr.4 (binary-sequence-to-hex-string (list 165))
+  "a5")
+
+(deftest :hexstr.5 (binary-sequence-to-hex-string #(165 86))
+  "a556")
+

 (deftest :apsl.1 (append-sublists '((a b) (c d))) (a b c d))
 (deftest :apsl.2 (append-sublists nil) nil)
 (deftest :apsl.3 (append-sublists '((a b))) (a b))
 (deftest :apsl.1 (append-sublists '((a b) (c d))) (a b c d))
 (deftest :apsl.2 (append-sublists nil) nil)
 (deftest :apsl.3 (append-sublists '((a b))) (a b))