+1 Apr 2011 Kevin Rosenberg <kevin@rosenberg.net>
+ * Version 1.104
+ * listener.lisp: Add support for active sockets in listener
+
17 Apr 2010 Kevin Rosenberg <kevin@rosenberg.net>
* Version 1.102
* btree.lisp: New file providing binary tree search for
year
hr min sec))))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defconstant +minute-seconds+ 60)
+ (defconstant +hour-seconds+ (* 60 +minute-seconds+))
+ (defconstant +day-seconds+ (* 24 +hour-seconds+))
+ (defconstant +week-seconds+ (* +day-seconds+ 7))
+ (defconstant +month-seconds+ (* +day-seconds+ (/ 365.25 12)))
+ (defconstant +year-seconds+ (* +day-seconds+ 365.25)))
+
+(defun seconds-to-condensed-time-string (sec &key (dp-digits 0))
+ "Prints a quantity of seconds as a condensed string. DP-DIGITS controls
+how many digits after decimal point."
+ (multiple-value-bind (year yrem) (floor (coerce sec 'double-float) +year-seconds+)
+ (multiple-value-bind (month mrem) (floor yrem +month-seconds+)
+ (multiple-value-bind (week wrem) (floor mrem +week-seconds+)
+ (multiple-value-bind (day drem) (floor wrem +day-seconds+)
+ (multiple-value-bind (hour hrem) (floor drem +hour-seconds+)
+ (multiple-value-bind (minute minrem) (floor hrem +minute-seconds+)
+ (let ((secstr (if (zerop dp-digits)
+ (format nil "~Ds" (round minrem))
+ (format nil (format nil "~~,~DFs" dp-digits) minrem))))
+ (cond
+ ((plusp year)
+ (format nil "~Dy~DM~Dw~Dd~Dh~Dm~A" year month week day hour minute secstr))
+ ((plusp month)
+ (format nil "~DM~Dw~Dd~Dh~Dm~A" month week day hour minute secstr))
+ ((plusp week)
+ (format nil "~Dw~Dd~Dh~Dm~A" week day hour minute secstr))
+ ((plusp day)
+ (format nil "~Dd~Dh~Dm~A" day hour minute secstr))
+ ((plusp hour)
+ (format nil "~Dh~Dm~A" hour minute secstr))
+ ((plusp minute)
+ (format nil "~Dm~A" minute secstr))
+ (t
+ secstr))))))))))
+
(defun print-seconds (secs)
(print-float-units secs "sec"))
+cl-kmrcl (1.105-1) unstable; urgency=low
+
+ * New upstream
+
+ -- Kevin M. Rosenberg <kmr@debian.org> Mon, 27 Jun 2011 00:02:42 -0600
+
+cl-kmrcl (1.104-1) unstable; urgency=low
+
+ * New upstream
+
+ -- Kevin M. Rosenberg <kmr@debian.org> Mon, 20 Jun 2011 15:55:57 -0600
+
cl-kmrcl (1.103-1) unstable; urgency=low
- * Remove UTF-8 code to allow compilation on CLISP
+ * Remove UTF-8 code to allow compilation on CLISP
-- Kevin M. Rosenberg <kmr@debian.org> Sun, 05 Sep 2010 22:26:17 -0600
Maintainer: Kevin M. Rosenberg <kmr@debian.org>
Build-Depends-Indep: dh-lisp
Build-Depends: debhelper (>= 7.0.0)
-Standards-Version: 3.9.1.0
+Standards-Version: 3.9.2.0
Homepage: http://files.b9.com/kmrcl/
Vcs-Git: git://git.b9.com/kmrcl.git
Vcs-Browser: http://git.b9.com/?p=kmrcl.git
source-files := $(filter-out $(tests-files),$(wildcard *.lisp))
-build:
+build: build-arch build-indep
+
+build-arch:
+
+build-indep:
clean:
dh_testdir
#!/bin/bash -e
-dup kmrcl -Ufiles.b9.com -D/home/ftp/kmrcl -C"(umask 022; cd /opt/apache/htdocs/kmrcl; make install)" -su $*
+dup kmrcl -Ufiles.b9.com -D/home/ftp/kmrcl -C"(umask 022; cd /srv/www/html/kmrcl; make install)" -su $*
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: hash.lisp
+;;;; Purpose: Hash functions for KMRCL package
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Apr 2000
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002-2011 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
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+
+(in-package #:kmrcl)
+
+;;; hashs
+
+(defun print-hash (h &key (stream *standard-output*)
+ key-transform-fn value-transform-fn
+ (prefix "") (divider " -> ") (terminator "~%"))
+ (maphash #'(lambda (k v)
+ (format stream "~A~S~A~S"
+ prefix
+ (if key-transform-fn
+ (funcall key-transform-fn k)
+ k)
+ divider
+ (if value-transform-fn
+ (funcall value-transform-fn v)
+ v))
+ (when terminator (format stream terminator)))
+ h)
+ h)
+
(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")))
+ (error "test-op failed")
+ t))
(:file "os" :depends-on ("macros" "impl"))
(:file "signals" :depends-on ("package"))
(:file "btree" :depends-on ("macros"))
+ (:file "hash" :depends-on ("macros"))
))
(defmethod perform ((o test-op) (c (eql (find-system 'kmrcl))))
(defclass worker (fixed-worker)
((connection :initarg :connection :accessor connection :initform nil)
+ (socket :initarg :socket :accessor socket :initform nil)
(thread-fun :initarg :thread-fun :accessor thread-fun :initform nil)))
(defun listener-shutdown (listener)
(dolist (worker (workers listener))
(when (and (typep worker 'worker)
- (connection worker))
+ (socket worker))
(errorset (close-active-socket
- (connection worker)) nil)
- (setf (connection worker) nil))
+ (socket worker)) nil)
+ (setf (connection worker) nil)
+ (setf (socket worker) nil))
(when (process worker)
(errorset (destroy-process (process worker)) nil)
(setf (process worker) nil)))
(defmethod initialize-instance :after
- ((self worker) &key listener connection name &allow-other-keys)
+ ((self worker) &key listener connection socket name &allow-other-keys)
(flet ((do-work ()
(apply (listener-function listener)
connection
(function-args listener))))
(unless connection
(error "connection not provided to modlisp-worker"))
+ (unless socket
+ (error "socket not provided to modlisp-worker"))
(setf (slot-value self 'listener) listener)
(setf (slot-value self 'name) name)
(setf (slot-value self 'connection) connection)
+ (setf (slot-value self 'socket) socket)
(setf (slot-value self 'thread-fun)
#'(lambda ()
(unwind-protect
(do-work)))
(progn
(errorset (finish-output connection) nil)
- (errorset (close-active-socket connection) nil)
+ (errorset (close-active-socket socket) t)
(cmsg-c :threads "~A ended" name)
(setf (workers listener)
(remove self (workers listener)))))))))
(not (funcall (remote-host-checker listener)
(remote-host socket))))
(cmsg-c :thread "Deny connection from ~A" (remote-host conn))
- (errorset (close-active-socket conn) nil)
- (setq conn nil))
- conn))
+ (errorset (close-active-socket socket) nil)
+ (setq conn nil socket nil))
+ (values conn socket)))
(defun start-socket-server (listener)
(unwind-protect
(loop
- (let ((connection (accept-and-check-tcp-connection listener)))
+ (multiple-value-bind (connection socket)
+ (accept-and-check-tcp-connection listener)
(when connection
(if (wait listener)
(unwind-protect
(errorset (close-active-socket connection) nil)))
(let ((worker (make-instance 'worker :listener listener
:connection connection
+ :socket socket
:name (next-worker-name
(base-name listener)))))
(setf (process worker)
(setf (cdr ,elem) ,val))
(,alist
(setf (cdr (last ,alist)) (list (cons ,akey ,val))))
- (t
- (setf ,alist (list (cons ,akey ,val)))))
+ (t
+ (setf ,alist (list (cons ,akey ,val)))))
,alist)))
(defun get-alist (key alist &key (test #'eql))
(update-alist key value alist :test test)
value)
+(defun remove-alist (key alist &key (test #'eql))
+ "Removes a key from an alist."
+ (remove key alist :test test :key #'car))
+
+(defun delete-alist (key alist &key (test #'eql))
+ "Deletes a key from an alist."
+ (delete key alist :test test :key #'car))
+
(defun alist-plist (alist)
(apply #'append (mapcar #'(lambda (x) (list (car x) (cdr x))) alist)))
`(/ (+ ,@args) ,(length args)))
(defmacro with-gensyms (syms &body body)
- `(let ,(mapcar #'(lambda (s) `(,s (gensym)))
+ `(let ,(mapcar #'(lambda (s) `(,s (gensym ,(format nil "~A-" s))))
syms)
,@body))
#:alistp
#:get-alist
#:update-alist
+ #:remove-alist
+ #:delete-alist
#:alist-plist
#:plist-alist
#:update-plist
#:print-separated-strings
#:lex-string
#:split-alphanumeric-string
+ #:safely-read-from-string
+ #:parse-float
;; strmatch.lisp
#:score-multiword-match
#:print-seconds
#:posix-time-to-utime
#:utime-to-posix-time
+ #:seconds-to-condensed-time-string
;; From random.lisp
#:seed-random-generator
;; mop.lisp
#:short-arg-cesd
#:short-arg-dsdc
+
+ ;; hash.lisp
+ #:print-hash
))
#+cmu (mp:make-process func :name name)
#+lispworks (mp:process-run-function name nil func)
#+sb-thread (sb-thread:make-thread func :name name)
- #+openmcl (ccl:process-run-function name func)
- #-(or allegro cmu lispworks sb-thread openmcl) (funcall func)
+ #+ccl (ccl:process-run-function name func)
+ #-(or allegro cmu lispworks sb-thread ccl) (funcall func)
)
(defun destroy-process (process)
#+allegro (mp:process-kill process)
#+sb-thread (sb-thread:destroy-thread process)
#+lispworks (mp:process-kill process)
- #+openmcl (ccl:process-kill process)
+ #+ccl (ccl:process-kill process)
)
(defun make-lock (name)
+ "Make a named process lock."
+ #+abcl (ext:make-thread-lock)
#+allegro (mp:make-process-lock :name name)
+ #+ccl (ccl:make-lock name)
#+cmu (mp:make-lock name)
#+lispworks (mp:make-lock :name name)
#+sb-thread (sb-thread:make-mutex :name name)
- #+openmcl (ccl:make-lock name)
- )
+ #-(or lispworks abcl openmcl allegro sb-thread)
+ (declare (ignore name))
+ #-(or abcl allegro ccl cmu lispworks sb-thread)
+ nil)
+
(defmacro with-lock-held ((lock) &body body)
+ #+abcl
+ `(ext:with-thread-lock (,lock) ,@body)
#+allegro
`(mp:with-process-lock (,lock) ,@body)
+ #+ccl
+ `(ccl:with-lock-grabbed (,lock) ,@body)
#+cmu
`(mp:with-lock-held (,lock) ,@body)
#+lispworks
`(mp:with-lock (,lock) ,@body)
#+sb-thread
`(sb-thread:with-recursive-lock (,lock) ,@body)
- #+openmcl
- `(ccl:with-lock-grabbed (,lock) ,@body)
- #-(or allegro cmu lispworks sb-thread openmcl)
+ #-(or abcl allegro ccl cmu lispworks sb-thread)
`(progn ,@body)
)
`(mp:with-timeout (,seconds) ,@body)
#+sb-thread
`(sb-ext:with-timeout ,seconds ,@body)
- #+openmcl
+ #+ccl
`(ccl:process-wait-with-timeout "waiting"
(* ,seconds ccl:*ticks-per-second*)
#'(lambda ()
,@body) nil)
- #-(or allegro cmu sb-thread openmcl)
+ #-(or allegro cmu sb-thread ccl)
`(progn ,@body)
)
(defun process-sleep (n)
+ "Put thread to sleep for n seconds."
#+allegro (mp:process-sleep n)
#-allegro (sleep n))
+
+
(do ((x (read stream nil eof) (read stream nil eof))
(l nil (cons x l)))
((eq x eof) (nreverse l))))))
+
+(defun safely-read-from-string (str &rest read-from-string-args)
+ "Read an expression from the string STR, with *READ-EVAL* set
+to NIL. Any unsafe expressions will be replaced by NIL in the
+resulting S-Expression."
+ (let ((*read-eval* nil))
+ (ignore-errors (apply 'read-from-string str read-from-string-args))))
+
+(defun parse-float (f)
+ (let ((*read-default-float-format* 'double-float))
+ (coerce (safely-read-from-string f) 'double-float)))
(encode-universal-time 0 0 0 1 11 2000)) nil)
)
+(deftest :sts.1
+ (seconds-to-condensed-time-string 0) "0s")
+(deftest :sts.2
+ (seconds-to-condensed-time-string 60) "1m0s")
+(deftest :sts.3
+ (seconds-to-condensed-time-string 65) "1m5s")
+(deftest :sts.4
+ (seconds-to-condensed-time-string 3600) "1h0m0s")
+(deftest :sts.5
+ (seconds-to-condensed-time-string 36000) "10h0m0s")
+(deftest :sts.6
+ (seconds-to-condensed-time-string 86400) "1d0h0m0s")
+(deftest :sts.7
+ (seconds-to-condensed-time-string (* 7 86400)) "1w0d0h0m0s")
+(deftest :sts.8
+ (seconds-to-condensed-time-string (* 21 86400)) "3w0d0h0m0s")
+(deftest :sts.9
+ (seconds-to-condensed-time-string (+ 86400 7200 120 50 (* 21 86400))) "3w1d2h2m50s")
+(deftest :sts.10
+ (seconds-to-condensed-time-string (+ .1 86400 7200 120 50 (* 21 86400))
+ :dp-digits 1) "3w1d2h2m50.1s")
(deftest :ekdc.1
(ensure-keyword-default-case (read-from-string "TYPE")) :type)
projects / kmrcl.git / commitdiff