From ieslick at common-lisp.net Mon Jul 3 00:36:37 2006 From: ieslick at common-lisp.net (ieslick) Date: Sun, 2 Jul 2006 20:36:37 -0400 (EDT) Subject: [elephant-cvs] CVS elephant/src/memutil Message-ID: <20060703003637.21E637801D@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/memutil In directory clnet:/tmp/cvs-serv10733 Modified Files: memutil.lisp Log Message: Added error checking for failure to allocate large buffer streams. Previously it failed silently. --- /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2006/06/19 01:31:59 1.7 +++ /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2006/07/03 00:36:37 1.8 @@ -443,6 +443,8 @@ (declare (type fixnum newlen)) (let ((newbuf (allocate-foreign-object :char newlen))) ;; technically we just need to copy from position to size..... + (when (null-pointer-p newbuf) + (error "Failed to allocate buffer stream of length ~A. allocate-foreign-object returned a null pointer" newlen)) (copy-bufs newbuf 0 buf 0 size) (free-foreign-object buf) (setf buf newbuf) @@ -462,6 +464,8 @@ (let ((newlen (max length (* len 2)))) (declare (type fixnum newlen)) (let ((newbuf (allocate-foreign-object :char newlen))) + (when (null-pointer-p newbuf) + (error "Failed to allocate buffer stream of length ~A. allocate-foreign-object returned a null pointer" newlen)) (free-foreign-object buf) (setf buf newbuf) (setf len newlen) From ieslick at common-lisp.net Fri Jul 21 16:28:17 2006 From: ieslick at common-lisp.net (ieslick) Date: Fri, 21 Jul 2006 12:28:17 -0400 (EDT) Subject: [elephant-cvs] CVS elephant/src/db-bdb Message-ID: <20060721162817.92624431BA@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv12259 Modified Files: bdb-controller.lisp Log Message: Updated bdb controller with shell-kill patch by aycan.irican at core.gen.tr --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2006/06/19 00:47:24 1.9 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2006/07/21 16:28:17 1.10 @@ -168,20 +168,29 @@ (when (find-package :port) (pushnew :port *features*))) -(defmethod start-deadlock-detector ((ctrlr bdb-store-controller) &key (type :oldest) (time 0.1) log) +(defun launch-background-program (directory program &key (args nil)) + "Launch a program in a specified directory - not all shell interfaces + or OS's support this" + #+(and allegro (not mswindows)) + (apply #'excl:run-shell-command (funcall #'vector directory program) + args) + #-(and allegro (not mswindows)) + nil) + +(defmethod start-deadlock-detector ((ctrl bdb-store-controller) &key (type :oldest) (time 0.1) log) #+port (multiple-value-bind (str errstr pid) - (port:run-prog (namestring - (make-pathname :directory "/usr/local/BerkeleyDB.4.3/bin/" - :name "db_deadlock")) - :args `("-a" ,(lookup-deadlock-type type) - "-t" ,(format nil "~D" time) - ,@(when log - (list "-L" (format nil "~A" log)))) - :wait nil) + (launch-background-program + (second (controller-spec ctrl)) + (namestring + (make-pathname :directory '(:ABSOLUTE "usr" "local" "BerkeleyDB.4.3" "bin") + :name "db_deadlock")) + :args `("-a" ,(lookup-deadlock-type type) + "-t" ,(format nil "~D" time) + ,@(when log (list "-L" (format nil "~A" log))))) (declare (ignore errstr)) - (setf (controller-deadlock-pid ctrlr) pid) - (setf (controller-deadlock-input ctrlr) str))) + (setf (controller-deadlock-pid ctrl) pid) + (setf (controller-deadlock-input ctrl) str))) (defmethod stop-deadlock-detector ((ctrl bdb-store-controller)) (when (controller-deadlock-pid ctrl) @@ -192,9 +201,9 @@ (setf (controller-deadlock-input ctrl) nil))) (defmethod shell-kill (pid) - #+allegro (sys:reap-os-subprocess :pid pid :wait t) - #+(port (not allegro)) (port:run-prog "kill" :wait t :args (list "-9" (format nil "~A" pid))) - ) + #+allegro (sys:reap-os-subprocess :pid pid :wait t) + #+(and (not allegro) port) (port:run-prog "kill" :wait t :args (list "-9" (format nil "~A" pid))) + #+(and sbcl linux) (sb-ext:process-kill "/bin/kill" (list "-9" (format nil "~A" pid)))) ;; ;; Persistent slot protocol From ieslick at common-lisp.net Fri Jul 21 16:32:45 2006 From: ieslick at common-lisp.net (ieslick) Date: Fri, 21 Jul 2006 12:32:45 -0400 (EDT) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20060721163245.4389852000@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv13874 Modified Files: classindex.lisp serializer.lisp Log Message: Updated classindex with typo fix by aycan.irican at core.gen.tr --- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2006/06/19 01:03:30 1.13 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2006/07/21 16:32:45 1.14 @@ -261,8 +261,8 @@ (add-index (find-class-index class :sc sc) :index-name slot-name :key-form (make-slot-key-form class slot-name) - :populate populate)) - t)) + :populate populate) + t))) (defmethod remove-class-slot-index ((class symbol) slot-name &key (sc *store-controller*)) (remove-class-slot-index (find-class class) slot-name :sc sc)) --- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2006/06/19 16:43:51 1.8 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2006/07/21 16:32:45 1.9 @@ -150,7 +150,7 @@ (let ((s (namestring frob))) (declare (type string s) (dynamic-extent s)) (buffer-write-byte - #+(and allegro ics) + #+(and allegro ics) (etypecase s (base-string +ucs1-pathname+) ;; +ucs1-pathname+ (string +ucs2-pathname+))