From dlichteblau at common-lisp.net Tue Jan 2 12:08:11 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Tue, 2 Jan 2007 07:08:11 -0500 (EST) Subject: [closure-cvs] CVS closure Message-ID: <20070102120811.09E3A690DD@common-lisp.net> Update of /project/closure/cvsroot/closure In directory clnet:/tmp/cvs-serv2676 Modified Files: closure.asd Log Message: depend on :MCCLIM, which loads :CLIM-LOOKS, rather than just :CLIM --- /project/closure/cvsroot/closure/closure.asd 2006/12/31 15:45:30 1.13 +++ /project/closure/cvsroot/closure/closure.asd 2007/01/02 12:08:10 1.14 @@ -83,7 +83,7 @@ (asdf:defsystem closure - :depends-on (:clim + :depends-on (:mcclim :clim-clx :glisp :bordeaux-threads) From dlichteblau at common-lisp.net Tue Jan 2 12:08:44 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Tue, 2 Jan 2007 07:08:44 -0500 (EST) Subject: [closure-cvs] CVS closure/src/renderer Message-ID: <20070102120844.CE5936D070@common-lisp.net> Update of /project/closure/cvsroot/closure/src/renderer In directory clnet:/tmp/cvs-serv2792 Modified Files: clim-device.lisp Log Message: commented out one of the two BACKGROUND-PIXMAP+MASK versions --- /project/closure/cvsroot/closure/src/renderer/clim-device.lisp 2005/07/17 09:38:54 1.13 +++ /project/closure/cvsroot/closure/src/renderer/clim-device.lisp 2007/01/02 12:08:44 1.14 @@ -160,34 +160,35 @@ (t spec))) -(defun background-pixmap+mask (document drawable bg) - (cond ((r2::background-%pixmap bg) - (values (r2::background-%pixmap bg) - (r2::background-%mask bg))) - (t - (setf (r2::background-%pixmap bg) :none) - (funcall ;;r2::run-process-on-behalf-of-document document - (lambda () - (let ((aimage (clue-gui2::aimage-from-url document (r2::background-image bg)))) - (cond ((eq aimage :error) - (setf (r2::background-%pixmap bg) :none) - (values (r2::background-%pixmap bg) - (r2::background-%mask bg))) - (t - (let ((pm (ws/x11::aimage->pixmap+mask drawable aimage))) - (setf (r2::background-%pixmap bg) (car pm) - (r2::background-%mask bg) (cadr pm)) - #+NIL - (clue-gui2::gui-post - nil - ;; we do it the hard way via an exposure round trip. - 'xlib:clear-area - drawable - :exposures-p t)))))) - ;;:name "Lazy Document background fetch." - ) - (values (r2::background-%pixmap bg) - (r2::background-%mask bg))))) +;; newer definition below +;;;(defun background-pixmap+mask (document drawable bg) +;;; (cond ((r2::background-%pixmap bg) +;;; (values (r2::background-%pixmap bg) +;;; (r2::background-%mask bg))) +;;; (t +;;; (setf (r2::background-%pixmap bg) :none) +;;; (funcall ;;r2::run-process-on-behalf-of-document document +;;; (lambda () +;;; (let ((aimage (clue-gui2::aimage-from-url document (r2::background-image bg)))) +;;; (cond ((eq aimage :error) +;;; (setf (r2::background-%pixmap bg) :none) +;;; (values (r2::background-%pixmap bg) +;;; (r2::background-%mask bg))) +;;; (t +;;; (let ((pm (ws/x11::aimage->pixmap+mask drawable aimage))) +;;; (setf (r2::background-%pixmap bg) (car pm) +;;; (r2::background-%mask bg) (cadr pm)) +;;; #+NIL +;;; (clue-gui2::gui-post +;;; nil +;;; ;; we do it the hard way via an exposure round trip. +;;; 'xlib:clear-area +;;; drawable +;;; :exposures-p t)))))) +;;; ;;:name "Lazy Document background fetch." +;;; ) +;;; (values (r2::background-%pixmap bg) +;;; (r2::background-%mask bg))))) (defmethod update-lazy-object (document (self null)) nil) From dlichteblau at common-lisp.net Tue Jan 2 12:43:09 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Tue, 2 Jan 2007 07:43:09 -0500 (EST) Subject: [closure-cvs] CVS closure/src/glisp Message-ID: <20070102124309.14AE7A106@common-lisp.net> Update of /project/closure/cvsroot/closure/src/glisp In directory clnet:/tmp/cvs-serv13051/src/glisp Modified Files: dep-acl.lisp dep-clisp.lisp dep-cmucl.lisp dep-scl.lisp Log Message: Removed some unused definitions from glisp. Also, versions of CLISP old enough to lack define-compiler-macro won't run McCLIM anyway. GCL left unchanged. --- /project/closure/cvsroot/closure/src/glisp/dep-acl.lisp 2006/12/31 15:42:40 1.4 +++ /project/closure/cvsroot/closure/src/glisp/dep-acl.lisp 2007/01/02 12:43:08 1.5 @@ -37,7 +37,6 @@ (defun glisp::read-char-sequence (&rest ap) (apply #'read-sequence ap)) -#+ALLEGRO-V5.0 (defun glisp::open-inet-socket (hostname port) (values (socket:make-socket :remote-host hostname @@ -45,20 +44,6 @@ :format :binary) :byte)) -#-ALLEGRO-V5.0 -(defun glisp::open-inet-socket (hostname port) - (values - (ipc:open-network-stream :host hostname - :port port - :element-type '(unsigned-byte 8) - :class 'EXCL::BIDIRECTIONAL-BINARY-SOCKET-STREAM) - :byte)) - -#|| -(defun glisp::make-server-socket (port &key (element-type '(unsigned-byte 8))) -) -||# - (defmacro glisp::with-timeout ((&rest options) &body body) `(mp:with-timeout ,options . ,body)) --- /project/closure/cvsroot/closure/src/glisp/dep-clisp.lisp 2006/12/31 15:42:40 1.4 +++ /project/closure/cvsroot/closure/src/glisp/dep-clisp.lisp 2007/01/02 12:43:08 1.5 @@ -28,38 +28,16 @@ (in-package :CL-USER) -(eval-when (compile load eval) - (if (fboundp 'cl::define-compiler-macro) - (pushnew 'define-compiler-macro *features*))) - (setq lisp:*load-paths* '(#P"./")) (import 'lisp:read-byte-sequence :glisp) (export 'lisp:read-byte-sequence :glisp) (import 'lisp:read-char-sequence :glisp) (export 'lisp:read-char-sequence :glisp) -(export 'glisp::compile-file :glisp) (export 'glisp::run-unix-shell-command :glisp) (export 'glisp::make-server-socket :glisp) -#|| -(export 'glisp::read-byte-sequence :glisp) -(defun glisp::read-byte-sequence (sequence input &key (start 0) (end (length sequence))) - (let (c (i start)) - (loop - (cond ((= i end) (return i))) - (setq c (read-byte input nil :eof)) - (cond ((eql c :eof) (return i))) - (setf (aref sequence i) c) - (incf i) ))) -||# - - -(defun glisp::compile-file (&rest ap) - (and (apply #'compile-file ap) - (apply #'compile-file-pathname ap))) - (defmacro glisp::with-timeout ((&rest ignore) &body body) (declare (ignore ignore)) `(progn @@ -94,32 +72,6 @@ (defun glisp:run-unix-shell-command (command) (lisp:shell command)) -#+DEFINE-COMPILER-MACRO -(cl:define-compiler-macro ldb (bytespec value &whole whole) - (let (pos size) - (cond ((and (consp bytespec) - (= (length bytespec) 3) - (eq (car bytespec) 'byte) - (constantp (setq size (second bytespec))) - (constantp (setq pos (third bytespec)))) - `(logand ,(if (eql pos 0) value `(ash ,value (- ,pos))) - (1- (ash 1 ,size)))) - (t - whole)))) - -#-DEFINE-COMPILER-MACRO -(progn - (export 'glisp::define-compiler-macro :glisp) - (defmacro glisp::define-compiler-macro (name args &body body) - (declare (ignore args body)) - `(progn - ',name))) - -#|| -(defun xlib:draw-glyph (drawable gcontext x y elt &rest more) - (apply #'xlib:draw-glyphs drawable gcontext x y (vector elt) more)) -||# - (export 'glisp::getenv :glisp) (defun glisp::getenv (var) (sys::getenv var)) --- /project/closure/cvsroot/closure/src/glisp/dep-cmucl.lisp 2006/12/31 15:42:40 1.4 +++ /project/closure/cvsroot/closure/src/glisp/dep-cmucl.lisp 2007/01/02 12:43:08 1.5 @@ -65,17 +65,6 @@ (t r)))) -#|| -(defun glisp::read-char-sequence (sequence input &key (start 0) (end (length sequence))) - (let (c (i start)) - (loop - (cond ((= i end) (return i))) - (setq c (read-byte input nil :eof)) - (cond ((eql c :eof) (return i))) - (setf (aref sequence i) c) - (incf i) ))) -||# - (defmacro glisp::with-timeout ((&rest ignore) &body body) (declare (ignore ignore)) `(progn @@ -115,88 +104,10 @@ (defun glisp::close-server-socket (socket) (unix:unix-close (server-socket-fd socket))) -;;;;;; - (defun glisp::g/make-string (length &rest options) (apply #'make-array length :element-type 'base-char options)) - -#|| - -RUN-PROGRAM is an external symbol in the EXTENSIONS package. -Function: # -Function arguments: - (program args &key (env *environment-list*) (wait t) pty input - if-input-does-not-exist output (if-output-exists :error) (error :output) - (if-error-exists :error) status-hook) -Function documentation: - Run-program creates a new process and runs the unix progam in the - file specified by the simple-string program. Args are the standard - arguments that can be passed to a Unix program, for no arguments - use NIL (which means just the name of the program is passed as arg 0). - - Run program will either return NIL or a PROCESS structure. See the CMU - Common Lisp Users Manual for details about the PROCESS structure. - - The keyword arguments have the following meanings: - :env - - An A-LIST mapping keyword environment variables to simple-string - values. - :wait - - If non-NIL (default), wait until the created process finishes. If - NIL, continue running Lisp until the program finishes. - :pty - - Either T, NIL, or a stream. Unless NIL, the subprocess is established - under a PTY. If :pty is a stream, all output to this pty is sent to - this stream, otherwise the PROCESS-PTY slot is filled in with a stream - connected to pty that can read output and write input. - :input - - Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard - input for the current process is inherited. If NIL, /dev/null - is used. If a pathname, the file so specified is used. If a stream, - all the input is read from that stream and send to the subprocess. If - :STREAM, the PROCESS-INPUT slot is filled in with a stream that sends - its output to the process. Defaults to NIL. - :if-input-does-not-exist (when :input is the name of a file) - - can be one of: - :error - generate an error. - :create - create an empty file. - nil (default) - return nil from run-program. - :output - - Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard - output for the current process is inherited. If NIL, /dev/null - is used. If a pathname, the file so specified is used. If a stream, - all the output from the process is written to this stream. If - :STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can - be read to get the output. Defaults to NIL. - :if-output-exists (when :input is the name of a file) - - can be one of: - :error (default) - generates an error if the file already exists. - :supersede - output from the program supersedes the file. - :append - output from the program is appended to the file. - nil - run-program returns nil without doing anything. - :error and :if-error-exists - - Same as :output and :if-output-exists, except that :error can also be - specified as :output in which case all error output is routed to the - same place as normal output. - :status-hook - - This is a function the system calls whenever the status of the - process changes. The function takes the process as an argument. -Its defined argument types are: - (T T &KEY (:ENV T) (:WAIT T) (:PTY T) (:INPUT T) (:IF-INPUT-DOES-NOT-EXIST T) - (:OUTPUT T) (:IF-OUTPUT-EXISTS T) (:ERROR T) (:IF-ERROR-EXISTS T) - (:STATUS-HOOK T)) -Its result type is: - (OR EXTENSIONS::PROCESS NULL) -On Wednesday, 7/1/98 12:48:51 pm [-1] it was compiled from: -target:code/run-program.lisp - Created: Saturday, 6/20/98 07:13:08 pm [-1] - Comment: $Header: /project/closure/cvsroot/closure/src/glisp/dep-cmucl.lisp,v 1.4 2006/12/31 15:42:40 dlichteblau Exp $ -||# - -;; (process-exit-code (run-program "/bin/sh" (list "-c" "ls") :wait t :input nil :output nil)) - (defun glisp:run-unix-shell-command (command) (ext:process-exit-code (ext:run-program "/bin/sh" (list "-c" command) :wait t :input nil :output nil))) --- /project/closure/cvsroot/closure/src/glisp/dep-scl.lisp 2006/12/31 15:42:40 1.2 +++ /project/closure/cvsroot/closure/src/glisp/dep-scl.lisp 2007/01/02 12:43:08 1.3 @@ -62,17 +62,6 @@ (t r)))) -#|| -(defun glisp::read-char-sequence (sequence input &key (start 0) (end (length sequence))) - (let (c (i start)) - (loop - (cond ((= i end) (return i))) - (setq c (read-byte input nil :eof)) - (cond ((eql c :eof) (return i))) - (setf (aref sequence i) c) - (incf i) ))) -||# - (defmacro glisp::with-timeout ((&rest ignore) &body body) (declare (ignore ignore)) `(progn @@ -91,86 +80,8 @@ (defun glisp::g/make-string (length &rest options) (apply #'make-array length :element-type 'base-char options)) -#|| - -RUN-PROGRAM is an external symbol in the EXTENSIONS package. -Function: # -Function arguments: - (program args &key (env *environment-list*) (wait t) pty input - if-input-does-not-exist output (if-output-exists :error) (error :output) - (if-error-exists :error) status-hook) -Function documentation: - Run-program creates a new process and runs the unix progam in the - file specified by the simple-string program. Args are the standard - arguments that can be passed to a Unix program, for no arguments - use NIL (which means just the name of the program is passed as arg 0). - - Run program will either return NIL or a PROCESS structure. See the CMU - Common Lisp Users Manual for details about the PROCESS structure. - - The keyword arguments have the following meanings: - :env - - An A-LIST mapping keyword environment variables to simple-string - values. - :wait - - If non-NIL (default), wait until the created process finishes. If - NIL, continue running Lisp until the program finishes. - :pty - - Either T, NIL, or a stream. Unless NIL, the subprocess is established - under a PTY. If :pty is a stream, all output to this pty is sent to - this stream, otherwise the PROCESS-PTY slot is filled in with a stream - connected to pty that can read output and write input. - :input - - Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard - input for the current process is inherited. If NIL, /dev/null - is used. If a pathname, the file so specified is used. If a stream, - all the input is read from that stream and send to the subprocess. If - :STREAM, the PROCESS-INPUT slot is filled in with a stream that sends - its output to the process. Defaults to NIL. - :if-input-does-not-exist (when :input is the name of a file) - - can be one of: - :error - generate an error. - :create - create an empty file. - nil (default) - return nil from run-program. - :output - - Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard - output for the current process is inherited. If NIL, /dev/null - is used. If a pathname, the file so specified is used. If a stream, - all the output from the process is written to this stream. If - :STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can - be read to get the output. Defaults to NIL. - :if-output-exists (when :input is the name of a file) - - can be one of: - :error (default) - generates an error if the file already exists. - :supersede - output from the program supersedes the file. - :append - output from the program is appended to the file. - nil - run-program returns nil without doing anything. - :error and :if-error-exists - - Same as :output and :if-output-exists, except that :error can also be - specified as :output in which case all error output is routed to the - same place as normal output. - :status-hook - - This is a function the system calls whenever the status of the - process changes. The function takes the process as an argument. -Its defined argument types are: - (T T &KEY (:ENV T) (:WAIT T) (:PTY T) (:INPUT T) (:IF-INPUT-DOES-NOT-EXIST T) - (:OUTPUT T) (:IF-OUTPUT-EXISTS T) (:ERROR T) (:IF-ERROR-EXISTS T) - (:STATUS-HOOK T)) -Its result type is: - (OR EXTENSIONS::PROCESS NULL) -On Wednesday, 7/1/98 12:48:51 pm [-1] it was compiled from: -target:code/run-program.lisp - Created: Saturday, 6/20/98 07:13:08 pm [-1] - Comment: $Header: /project/closure/cvsroot/closure/src/glisp/dep-scl.lisp,v 1.2 2006/12/31 15:42:40 dlichteblau Exp $ -||# - -;; (process-exit-code (run-program "/bin/sh" (list "-c" "ls") :wait t :input nil :output nil)) - (defun glisp:run-unix-shell-command (command) (ext:process-exit-code (ext:run-program "/bin/sh" (list "-c" command) :wait t :input nil :output nil))) - -;;; MP - (defun glisp::getenv (string) (cdr (assoc string ext:*environment-list* :test #'string-equal))) From dlichteblau at common-lisp.net Tue Jan 2 12:47:30 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Tue, 2 Jan 2007 07:47:30 -0500 (EST) Subject: [closure-cvs] CVS closure/src/glisp Message-ID: <20070102124730.C145022014@common-lisp.net> Update of /project/closure/cvsroot/closure/src/glisp In directory clnet:/tmp/cvs-serv14063 Modified Files: dep-openmcl.lisp Log Message: Un-RMAIL-ify dep-openmcl.lisp... --- /project/closure/cvsroot/closure/src/glisp/dep-openmcl.lisp 2006/12/31 15:42:40 1.3 +++ /project/closure/cvsroot/closure/src/glisp/dep-openmcl.lisp 2007/01/02 12:47:30 1.4 @@ -1,54 +1,3 @@ -BABYL OPTIONS: -*- rmail -*- -Version: 5 -Labels: -Note: This is the header of an rmail file. -Note: If you are seeing it in rmail, -Note: it means the file has no messages in it. - -1,, -X-From-Line: splittist at yahoo.com Thu Aug 25 15:53:13 2005 -Return-path: -Envelope-to: real-csr21 at localhost -Delivery-date: Thu, 25 Aug 2005 15:53:13 +0100 -Received: from [127.0.0.1] (helo=localhost) - by mu with esmtp (Exim 4.52) - id 1E8J6P-0003Ya-6b - for real-csr21 at localhost; Thu, 25 Aug 2005 15:53:13 +0100 -Received: from imap.hermes.cam.ac.uk [131.111.8.159] - by localhost with IMAP (fetchmail-6.2.5.1) - for real-csr21 at localhost (single-drop); Thu, 25 Aug 2005 15:53:13 +0100 (BST) -Received: from ppsw-9-intramail.csi.cam.ac.uk ([192.168.128.139]) - by cyrus-5.csi.private.cam.ac.uk (Cyrus v2.1.16-HERMES) - with LMTP; Thu, 25 Aug 2005 15:47:51 +0100 -X-Sieve: CMU Sieve 2.2 -X-Cam-SpamScore: ss -X-Cam-SpamDetails: scanned, SpamAssassin (score=2.174, - FORGED_YAHOO_RCVD 2.17) -X-Cam-AntiVirus: No virus found -X-Cam-ScannerInfo: http://www.cam.ac.uk/cs/email/scanner/ -Received: from cmailg1.svr.pol.co.uk ([195.92.195.171]:3765) - by ppsw-9.csi.cam.ac.uk (mx.cam.ac.uk [131.111.8.149]:25) - with esmtp (csa=unknown) id 1E8J16-0005kv-Tr (Exim 4.51) for csr21 at cam.ac.uk - (return-path ); Thu, 25 Aug 2005 15:47:44 +0100 -Received: from user-2261.l2.c5.dsl.pol.co.uk ([81.76.40.213] helo=[192.168.1.26]) - by cmailg1.svr.pol.co.uk with esmtp (Exim 4.41) - id 1E8J12-0007ZL-9M; Thu, 25 Aug 2005 15:47:40 +0100 -X-Gnus-Mail-Source: file:/var/mail/csr21 -Message-ID: <430DDA0B.3010307 at yahoo.com> -Date: Thu, 25 Aug 2005 15:47:39 +0100 -From: John Q Splittist -User-Agent: Mozilla Thunderbird 1.0.6 (Macintosh/20050716) -X-Accept-Language: en-us, en -MIME-Version: 1.0 -To: closure-devel at common-lisp.net -CC: Christophe Rhodes -Subject: Openmcl patches -Content-Type: multipart/mixed; - boundary="------------030203070203000802030803" -Lines: 285 -Xref: mu list.closure-devel:8 - -*** EOOH *** ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CL-USER; -*- ;;; --------------------------------------------------------------------------- ;;; Title: OpenMCL dependent stuff + fixups @@ -147,4 +96,3 @@ (defun glisp::getenv (string) (ccl::getenv string)) - \ No newline at end of file From dlichteblau at common-lisp.net Tue Jan 2 12:50:40 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Tue, 2 Jan 2007 07:50:40 -0500 (EST) Subject: [closure-cvs] CVS closure/src/glisp Message-ID: <20070102125040.2BC5025002@common-lisp.net> Update of /project/closure/cvsroot/closure/src/glisp In directory clnet:/tmp/cvs-serv14680 Modified Files: dep-acl.lisp dep-clisp.lisp dep-cmucl.lisp dep-openmcl.lisp dep-sbcl.lisp dep-scl.lisp package.lisp Log Message: removed all top-level calls to EXPORT in favour of the defpackage --- /project/closure/cvsroot/closure/src/glisp/dep-acl.lisp 2007/01/02 12:43:08 1.5 +++ /project/closure/cvsroot/closure/src/glisp/dep-acl.lisp 2007/01/02 12:50:39 1.6 @@ -26,11 +26,6 @@ ;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -(export 'glisp::read-byte-sequence :glisp) -(export 'glisp::read-char-sequence :glisp) -(export 'glisp::run-unix-shell-command :glisp) -(export 'glisp::getenv :glisp) - (defun glisp::read-byte-sequence (&rest ap) (apply #'read-sequence ap)) --- /project/closure/cvsroot/closure/src/glisp/dep-clisp.lisp 2007/01/02 12:43:08 1.5 +++ /project/closure/cvsroot/closure/src/glisp/dep-clisp.lisp 2007/01/02 12:50:39 1.6 @@ -30,14 +30,6 @@ (setq lisp:*load-paths* '(#P"./")) -(import 'lisp:read-byte-sequence :glisp) -(export 'lisp:read-byte-sequence :glisp) -(import 'lisp:read-char-sequence :glisp) -(export 'lisp:read-char-sequence :glisp) -(export 'glisp::run-unix-shell-command :glisp) -(export 'glisp::make-server-socket :glisp) - - (defmacro glisp::with-timeout ((&rest ignore) &body body) (declare (ignore ignore)) `(progn @@ -48,6 +40,7 @@ (lisp:socket-connect port hostname) :byte)) +(export 'glisp::make-server-socket :glisp) (defun glisp:make-server-socket (port) (lisp:socket-server port)) --- /project/closure/cvsroot/closure/src/glisp/dep-cmucl.lisp 2007/01/02 12:43:08 1.5 +++ /project/closure/cvsroot/closure/src/glisp/dep-cmucl.lisp 2007/01/02 12:50:39 1.6 @@ -26,15 +26,6 @@ ;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -(export 'glisp::read-byte-sequence :glisp) -(export 'glisp::read-char-sequence :glisp) -(export 'glisp::run-unix-shell-command :glisp) - -(export 'glisp::getenv :glisp) - -(export 'glisp::make-server-socket :glisp) -(export 'glisp::close-server-socket :glisp) - (defun glisp::read-byte-sequence (&rest ap) (apply #'read-sequence ap)) @@ -85,6 +76,7 @@ element-type port) +(export 'glisp::make-server-socket :glisp) (defun glisp::make-server-socket (port &key (element-type '(unsigned-byte 8))) (make-server-socket-struct :fd (ext:create-inet-listener port) :element-type element-type @@ -101,6 +93,7 @@ (t :char)))) +(export 'glisp::close-server-socket :glisp) (defun glisp::close-server-socket (socket) (unix:unix-close (server-socket-fd socket))) --- /project/closure/cvsroot/closure/src/glisp/dep-openmcl.lisp 2007/01/02 12:47:30 1.4 +++ /project/closure/cvsroot/closure/src/glisp/dep-openmcl.lisp 2007/01/02 12:50:39 1.5 @@ -26,15 +26,6 @@ ;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -(export 'glisp::read-byte-sequence :glisp) -(export 'glisp::read-char-sequence :glisp) -(export 'glisp::run-unix-shell-command :glisp) - -(export 'glisp::getenv :glisp) - -(export 'glisp::make-server-socket :glisp) -(export 'glisp::close-server-socket :glisp) - (defun glisp::read-byte-sequence (&rest ap) (apply #'read-sequence ap)) @@ -61,6 +52,7 @@ #|| +(export 'glisp::make-server-socket :glisp) (defun glisp::make-server-socket (port &key (element-type '(unsigned-byte 8))) (make-server-socket-struct :fd (ext:create-inet-listener port) :element-type element-type @@ -78,6 +70,7 @@ (t :char)))) +(export 'glisp::close-server-socket :glisp) (defun glisp::close-server-socket (socket) (unix:unix-close (server-socket-fd socket))) ||# --- /project/closure/cvsroot/closure/src/glisp/dep-sbcl.lisp 2006/12/31 15:42:40 1.5 +++ /project/closure/cvsroot/closure/src/glisp/dep-sbcl.lisp 2007/01/02 12:50:39 1.6 @@ -26,15 +26,6 @@ ;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -(export 'glisp::read-byte-sequence :glisp) -(export 'glisp::read-char-sequence :glisp) -(export 'glisp::run-unix-shell-command :glisp) - -(export 'glisp::getenv :glisp) - -(export 'glisp::make-server-socket :glisp) -(export 'glisp::close-server-socket :glisp) - (defun glisp::read-byte-sequence (&rest ap) (apply #'read-sequence ap)) @@ -67,6 +58,7 @@ #|| +(export 'glisp::make-server-socket :glisp) (defun glisp::make-server-socket (port &key (element-type '(unsigned-byte 8))) (make-server-socket-struct :fd (ext:create-inet-listener port) :element-type element-type @@ -84,6 +76,7 @@ (t :char)))) +(export 'glisp::close-server-socket :glisp) (defun glisp::close-server-socket (socket) (unix:unix-close (server-socket-fd socket))) ||# --- /project/closure/cvsroot/closure/src/glisp/dep-scl.lisp 2007/01/02 12:43:08 1.3 +++ /project/closure/cvsroot/closure/src/glisp/dep-scl.lisp 2007/01/02 12:50:39 1.4 @@ -26,12 +26,6 @@ ;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -(export 'glisp::read-byte-sequence :glisp) -(export 'glisp::read-char-sequence :glisp) -(export 'glisp::run-unix-shell-command :glisp) - -(export 'glisp::getenv :glisp) - (defun glisp::read-byte-sequence (&rest ap) (apply #'read-sequence ap)) --- /project/closure/cvsroot/closure/src/glisp/package.lisp 2006/12/31 15:42:40 1.8 +++ /project/closure/cvsroot/closure/src/glisp/package.lisp 2007/01/02 12:50:39 1.9 @@ -119,7 +119,13 @@ ;; match.lisp "DEFINE-MATCH-MACRO" "IF-MATCH" - "GSTREAM-AS-STRING")) + "GSTREAM-AS-STRING" + + ;; dep-* + "READ-BYTE-SEQUENCE" + "READ-CHAR-SEQUENCE" + "RUN-UNIX-SHELL-COMMAND" + "GETENV")) (defpackage "GLUSER" (:use "CL" "GLISP")) From dlichteblau at common-lisp.net Tue Jan 2 12:51:13 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Tue, 2 Jan 2007 07:51:13 -0500 (EST) Subject: [closure-cvs] CVS closure/src/glisp Message-ID: <20070102125113.618722F044@common-lisp.net> Update of /project/closure/cvsroot/closure/src/glisp In directory clnet:/tmp/cvs-serv14855 Removed Files: gendep.lisp Log Message: removed gendep.lisp From dlichteblau at common-lisp.net Tue Jan 2 12:54:01 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Tue, 2 Jan 2007 07:54:01 -0500 (EST) Subject: [closure-cvs] CVS closure/src/glisp Message-ID: <20070102125401.0E4332F044@common-lisp.net> Update of /project/closure/cvsroot/closure/src/glisp In directory clnet:/tmp/cvs-serv15471/src/glisp Modified Files: dep-clisp.lisp dep-cmucl.lisp dep-openmcl.lisp dep-sbcl.lisp package.lisp util.lisp Log Message: removed server socket code (unused) --- /project/closure/cvsroot/closure/src/glisp/dep-clisp.lisp 2007/01/02 12:50:39 1.6 +++ /project/closure/cvsroot/closure/src/glisp/dep-clisp.lisp 2007/01/02 12:54:00 1.7 @@ -40,17 +40,6 @@ (lisp:socket-connect port hostname) :byte)) -(export 'glisp::make-server-socket :glisp) -(defun glisp:make-server-socket (port) - (lisp:socket-server port)) - -(defun glisp::accept-connection/low (socket) - (let ((stream (lisp:socket-accept socket))) - (setf (stream-element-type stream) '(unsigned-byte 8)) - (values - stream - :byte))) - (defun glisp::g/make-string (length &rest options) (apply #'make-array length :element-type --- /project/closure/cvsroot/closure/src/glisp/dep-cmucl.lisp 2007/01/02 12:50:39 1.6 +++ /project/closure/cvsroot/closure/src/glisp/dep-cmucl.lisp 2007/01/02 12:54:00 1.7 @@ -71,32 +71,6 @@ :name (format nil "Network connection to ~A:~D" hostname port)) :byte))) -(defstruct (server-socket (:constructor make-server-socket-struct)) - fd - element-type - port) - -(export 'glisp::make-server-socket :glisp) -(defun glisp::make-server-socket (port &key (element-type '(unsigned-byte 8))) - (make-server-socket-struct :fd (ext:create-inet-listener port) - :element-type element-type - :port port)) - -(defun glisp::accept-connection/low (socket) - (mp:process-wait-until-fd-usable (server-socket-fd socket) :input) - (values - (sys:make-fd-stream (ext:accept-tcp-connection (server-socket-fd socket)) - :input t :output t - :element-type (server-socket-element-type socket)) - (cond ((subtypep (server-socket-element-type socket) 'integer) - :byte) - (t - :char)))) - -(export 'glisp::close-server-socket :glisp) -(defun glisp::close-server-socket (socket) - (unix:unix-close (server-socket-fd socket))) - (defun glisp::g/make-string (length &rest options) (apply #'make-array length :element-type 'base-char options)) --- /project/closure/cvsroot/closure/src/glisp/dep-openmcl.lisp 2007/01/02 12:50:39 1.5 +++ /project/closure/cvsroot/closure/src/glisp/dep-openmcl.lisp 2007/01/02 12:54:00 1.6 @@ -45,38 +45,6 @@ :remote-port port) :byte)) -(defstruct (server-socket (:constructor make-server-socket-struct)) - fd - element-type - port) - - -#|| -(export 'glisp::make-server-socket :glisp) -(defun glisp::make-server-socket (port &key (element-type '(unsigned-byte 8))) - (make-server-socket-struct :fd (ext:create-inet-listener port) - :element-type element-type - :port port)) - - -(defun glisp::accept-connection/low (socket) - (mp:process-wait-until-fd-usable (server-socket-fd socket) :input) - (values - (sys:make-fd-stream (ext:accept-tcp-connection (server-socket-fd socket)) - :input t :output t - :element-type (server-socket-element-type socket)) - (cond ((subtypep (server-socket-element-type socket) 'integer) - :byte) - (t - :char)))) - -(export 'glisp::close-server-socket :glisp) -(defun glisp::close-server-socket (socket) - (unix:unix-close (server-socket-fd socket))) -||# - -;;;;;; - (defun glisp::g/make-string (length &rest options) (apply #'make-array length :element-type 'base-char options)) --- /project/closure/cvsroot/closure/src/glisp/dep-sbcl.lisp 2007/01/02 12:50:39 1.6 +++ /project/closure/cvsroot/closure/src/glisp/dep-sbcl.lisp 2007/01/02 12:54:00 1.7 @@ -51,38 +51,6 @@ :input t :output t) :byte)) -(defstruct (server-socket (:constructor make-server-socket-struct)) - fd - element-type - port) - - -#|| -(export 'glisp::make-server-socket :glisp) -(defun glisp::make-server-socket (port &key (element-type '(unsigned-byte 8))) - (make-server-socket-struct :fd (ext:create-inet-listener port) - :element-type element-type - :port port)) - - -(defun glisp::accept-connection/low (socket) - (mp:process-wait-until-fd-usable (server-socket-fd socket) :input) - (values - (sys:make-fd-stream (ext:accept-tcp-connection (server-socket-fd socket)) - :input t :output t - :element-type (server-socket-element-type socket)) - (cond ((subtypep (server-socket-element-type socket) 'integer) - :byte) - (t - :char)))) - -(export 'glisp::close-server-socket :glisp) -(defun glisp::close-server-socket (socket) - (unix:unix-close (server-socket-fd socket))) -||# - -;;;;;; - (defun glisp::g/make-string (length &rest options) (apply #'make-array length :element-type 'character options)) --- /project/closure/cvsroot/closure/src/glisp/package.lisp 2007/01/02 12:50:39 1.9 +++ /project/closure/cvsroot/closure/src/glisp/package.lisp 2007/01/02 12:54:00 1.10 @@ -88,7 +88,6 @@ "CL-BYTE-STREAM->GSTREAM" "CL-CHAR-STREAM->GSTREAM" "G/OPEN-INET-SOCKET" - "ACCEPT-CONNECTION" "FIND-TEMPORARY-FILE" "DELETE-TEMPORARY-FILE" --- /project/closure/cvsroot/closure/src/glisp/util.lisp 2006/12/31 12:14:36 1.6 +++ /project/closure/cvsroot/closure/src/glisp/util.lisp 2007/01/02 12:54:00 1.7 @@ -678,18 +678,6 @@ (:char (cl-char-stream->gstream stream)) (:byte (cl-byte-stream->gstream stream)) ))) -#|| -(defun g/open-inet-socket-ssl (host port) - (multiple-value-bind (stream) (gluser::make-ssl-client-socket host port) - (cl-byte-stream->gstream stream))) -||# - -(defun accept-connection (socket) - (multiple-value-bind (stream kind) (accept-connection/low socket) - (ecase kind - (:char (cl-char-stream->gstream stream)) - (:byte (cl-byte-stream->gstream stream)) ))) - ;;; ---------------------------------------------------------------------------------------------------- From dlichteblau at common-lisp.net Tue Jan 2 13:12:58 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Tue, 2 Jan 2007 08:12:58 -0500 (EST) Subject: [closure-cvs] CVS closure Message-ID: <20070102131258.1D58A6B562@common-lisp.net> Update of /project/closure/cvsroot/closure In directory clnet:/tmp/cvs-serv24908 Modified Files: closure.asd Log Message: Removed open-inet-socket from dep-*. Move g/open-inet-socket from glisp into net/. [Its :char case was never being used, all implementations used :byte.] Depend on trivial-sockets to create the socket. Usocket seems to be better maintained, but has trivial-sockets compatibility and our socket needs are "trivial" right now. --- /project/closure/cvsroot/closure/closure.asd 2007/01/02 12:08:10 1.14 +++ /project/closure/cvsroot/closure/closure.asd 2007/01/02 13:12:57 1.15 @@ -86,7 +86,8 @@ :depends-on (:mcclim :clim-clx :glisp - :bordeaux-threads) + :bordeaux-threads + :trivial-sockets) :default-component-class closure-source-file :components ((:module src From dlichteblau at common-lisp.net Tue Jan 2 13:13:03 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Tue, 2 Jan 2007 08:13:03 -0500 (EST) Subject: [closure-cvs] CVS closure/src/glisp Message-ID: <20070102131303.3D876702EB@common-lisp.net> Update of /project/closure/cvsroot/closure/src/glisp In directory clnet:/tmp/cvs-serv24908/src/glisp Modified Files: dep-acl.lisp dep-clisp.lisp dep-cmucl.lisp dep-openmcl.lisp dep-sbcl.lisp dep-scl.lisp package.lisp util.lisp Log Message: Removed open-inet-socket from dep-*. Move g/open-inet-socket from glisp into net/. [Its :char case was never being used, all implementations used :byte.] Depend on trivial-sockets to create the socket. Usocket seems to be better maintained, but has trivial-sockets compatibility and our socket needs are "trivial" right now. --- /project/closure/cvsroot/closure/src/glisp/dep-acl.lisp 2007/01/02 12:50:39 1.6 +++ /project/closure/cvsroot/closure/src/glisp/dep-acl.lisp 2007/01/02 13:12:58 1.7 @@ -32,13 +32,6 @@ (defun glisp::read-char-sequence (&rest ap) (apply #'read-sequence ap)) -(defun glisp::open-inet-socket (hostname port) - (values - (socket:make-socket :remote-host hostname - :remote-port port - :format :binary) - :byte)) - (defmacro glisp::with-timeout ((&rest options) &body body) `(mp:with-timeout ,options . ,body)) --- /project/closure/cvsroot/closure/src/glisp/dep-clisp.lisp 2007/01/02 12:54:00 1.7 +++ /project/closure/cvsroot/closure/src/glisp/dep-clisp.lisp 2007/01/02 13:12:58 1.8 @@ -35,11 +35,6 @@ `(progn , at body)) -(defun glisp::open-inet-socket (hostname port) - (values - (lisp:socket-connect port hostname) - :byte)) - (defun glisp::g/make-string (length &rest options) (apply #'make-array length :element-type --- /project/closure/cvsroot/closure/src/glisp/dep-cmucl.lisp 2007/01/02 12:54:00 1.7 +++ /project/closure/cvsroot/closure/src/glisp/dep-cmucl.lisp 2007/01/02 13:12:58 1.8 @@ -61,16 +61,6 @@ `(progn , at body)) -(defun glisp::open-inet-socket (hostname port) - (let ((fd (extensions:connect-to-inet-socket hostname port))) - (values - (sys:make-fd-stream fd - :input t - :output t - :element-type '(unsigned-byte 8) - :name (format nil "Network connection to ~A:~D" hostname port)) - :byte))) - (defun glisp::g/make-string (length &rest options) (apply #'make-array length :element-type 'base-char options)) --- /project/closure/cvsroot/closure/src/glisp/dep-openmcl.lisp 2007/01/02 12:54:00 1.6 +++ /project/closure/cvsroot/closure/src/glisp/dep-openmcl.lisp 2007/01/02 13:12:58 1.7 @@ -37,19 +37,9 @@ `(progn , at body)) -(defun glisp::open-inet-socket (hostname port) - (values - (ccl::make-socket :address-family :internet - :type :stream - :remote-host hostname - :remote-port port) - :byte)) - (defun glisp::g/make-string (length &rest options) (apply #'make-array length :element-type 'base-char options)) - - (defun glisp::run-unix-shell-command (command) (nth-value 1 (ccl:external-process-status (ccl:run-program "/bin/sh" (list "-c" command) :wait t :input nil --- /project/closure/cvsroot/closure/src/glisp/dep-sbcl.lisp 2007/01/02 12:54:00 1.7 +++ /project/closure/cvsroot/closure/src/glisp/dep-sbcl.lisp 2007/01/02 13:12:58 1.8 @@ -37,25 +37,9 @@ `(progn , at body)) -(defun glisp::open-inet-socket (hostname port) - (values - (sb-bsd-sockets:socket-make-stream - (let ((host (car (sb-bsd-sockets:host-ent-addresses - (sb-bsd-sockets:get-host-by-name hostname))))) - (when host - (let ((s (make-instance 'sb-bsd-sockets:inet-socket - :type :stream :protocol :tcp))) - (sb-bsd-sockets:socket-connect s host port) - s))) - :element-type '(unsigned-byte 8) - :input t :output t) - :byte)) - (defun glisp::g/make-string (length &rest options) (apply #'make-array length :element-type 'character options)) - - (defun glisp::run-unix-shell-command (command) (sb-impl::process-exit-code (sb-ext:run-program "/bin/sh" (list "-c" command) :wait t :input nil --- /project/closure/cvsroot/closure/src/glisp/dep-scl.lisp 2007/01/02 12:50:39 1.4 +++ /project/closure/cvsroot/closure/src/glisp/dep-scl.lisp 2007/01/02 13:12:58 1.5 @@ -61,16 +61,6 @@ `(progn , at body)) -(defun glisp::open-inet-socket (hostname port) - (let ((fd (extensions:connect-to-inet-socket hostname port))) - (values - (sys:make-fd-stream fd - :input t - :output t - :element-type '(unsigned-byte 8) - :name (format nil "Network connection to ~A:~D" hostname port)) - :byte))) - (defun glisp::g/make-string (length &rest options) (apply #'make-array length :element-type 'base-char options)) --- /project/closure/cvsroot/closure/src/glisp/package.lisp 2007/01/02 12:54:00 1.10 +++ /project/closure/cvsroot/closure/src/glisp/package.lisp 2007/01/02 13:12:58 1.11 @@ -33,7 +33,7 @@ (:export "DEFSUBST" "G/MAKE-STRING" "WITH-TIMEOUT" - "OPEN-INET-SOCKET" + ;; util.lisp : "ALWAYS" "CL-BYTE-STREAM" @@ -87,7 +87,6 @@ "CL-BYTE-STREAM->GSTREAM" "CL-CHAR-STREAM->GSTREAM" - "G/OPEN-INET-SOCKET" "FIND-TEMPORARY-FILE" "DELETE-TEMPORARY-FILE" --- /project/closure/cvsroot/closure/src/glisp/util.lisp 2007/01/02 12:54:00 1.7 +++ /project/closure/cvsroot/closure/src/glisp/util.lisp 2007/01/02 13:12:58 1.8 @@ -671,14 +671,6 @@ (defun cl-char-stream->gstream (stream) (make-instance 'cl-char-stream :cl-stream stream)) -(defun g/open-inet-socket (&rest args) - (multiple-value-bind (stream kind) (apply #'open-inet-socket args) - (ecase kind - #-CMU - (:char (cl-char-stream->gstream stream)) - (:byte (cl-byte-stream->gstream stream)) ))) - - ;;; ---------------------------------------------------------------------------------------------------- (defvar *all-temporary-files* nil From dlichteblau at common-lisp.net Tue Jan 2 13:13:03 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Tue, 2 Jan 2007 08:13:03 -0500 (EST) Subject: [closure-cvs] CVS closure/src/net Message-ID: <20070102131303.B000872088@common-lisp.net> Update of /project/closure/cvsroot/closure/src/net In directory clnet:/tmp/cvs-serv24908/src/net Modified Files: ftp.lisp http.lisp Log Message: Removed open-inet-socket from dep-*. Move g/open-inet-socket from glisp into net/. [Its :char case was never being used, all implementations used :byte.] Depend on trivial-sockets to create the socket. Usocket seems to be better maintained, but has trivial-sockets compatibility and our socket needs are "trivial" right now. --- /project/closure/cvsroot/closure/src/net/ftp.lisp 2006/12/31 15:42:41 1.3 +++ /project/closure/cvsroot/closure/src/net/ftp.lisp 2007/01/02 13:13:03 1.4 @@ -254,6 +254,10 @@ (setf message (concatenate 'string message (string #\newline) line)))) (values response-code message))))) +(defun g/open-inet-socket (host port) + (cl-byte-stream->gstream + (trivial-sockets:open-stream host port :element-type '(unsigned-byte 8)))) + (defmethod ftp/initiate-connection ((self ftp-connection)) (with-slots (io host port) self (setf io (g/open-inet-socket host port)) --- /project/closure/cvsroot/closure/src/net/http.lisp 2006/12/31 15:42:41 1.10 +++ /project/closure/cvsroot/closure/src/net/http.lisp 2007/01/02 13:13:03 1.11 @@ -310,22 +310,24 @@ ;; -> io proxyp (let* ((host (or (url:url-host url) "localhost")) (https-p (string= (url:url-protocol url) "https")) + ;; ### HTTPS support doesn't exist (port (or (url:url-port url) (if https-p 443 - 80))) - (opener (if https-p - #'glisp::g/open-inet-socket-ssl - #'g/open-inet-socket)) + 80))) (proxyp (and *use-http-proxy-p* (= port 80) (not (url:url-port url)) (not (string-equal host "localhost"))))) (values - (cond (proxyp - (funcall opener *http-proxy-host* *http-proxy-port*)) - (t - (funcall opener host port))) + (cl-byte-stream->gstream + (if proxyp + (trivial-sockets:open-stream *http-proxy-host* + *http-proxy-port* + :element-type '(unsigned-byte 8)) + (trivial-sockets:open-stream host + port + :element-type '(unsigned-byte 8)))) proxyp))) (defun http-make-request (method url header post-data) From dlichteblau at common-lisp.net Tue Jan 2 14:00:54 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Tue, 2 Jan 2007 09:00:54 -0500 (EST) Subject: [closure-cvs] CVS closure/src/html Message-ID: <20070102140054.8675C2B13C@common-lisp.net> Update of /project/closure/cvsroot/closure/src/html In directory clnet:/tmp/cvs-serv6682 Modified Files: html-style.lisp Log Message: rune fixes --- /project/closure/cvsroot/closure/src/html/html-style.lisp 2006/12/31 15:42:41 1.10 +++ /project/closure/cvsroot/closure/src/html/html-style.lisp 2007/01/02 14:00:54 1.11 @@ -286,7 +286,7 @@ ;; NOTE: The if-match macro is defined in match.lisp (define-match-macro integer (&optional (radix 10)) - `(& (? (/ #.(char-code #\+) #.(char-code #\-))) + `(& (? (/ #/+ #/-)) (+ (p (lambda (ch) (digit-rune-p ch ,radix)))))) (define-match-macro w* () @@ -303,14 +303,14 @@ (& (w*) (= $res (integer)) (w*)) (cons :px (parse-integer (rod-string (subseq s $res-start $res-end))))) (if-match (s :type rod :test #'rune=) - (& (w*) (= $res (integer)) #.(char-code #\%) (w*)) + (& (w*) (= $res (integer)) #/% (w*)) (cons :% (parse-integer (rod-string (subseq s $res-start $res-end))))))) (defun html/parse-multi-length (s) (or (html/parse-length s) (if-match (s :type rod :test #'rune=) - (& (w*) (= $res (integer)) #.(char-code #\*) (w*)) + (& (w*) (= $res (integer)) #/* (w*)) (cons '* (parse-integer (rod-string (subseq s $res-start $res-end))))) ;; This below is illegal syntax '*i' is not allowed #+(OR) @@ -319,7 +319,7 @@ (cons '* (parse-integer (rod-string (subseq s $res-start $res-end))))) ;; "*" is abbrev for "1*" (if-match (s :type rod :test #'rune=) - (& (w*) #.(char-code #\*) (w*)) + (& (w*) #/* (w*)) (cons '* 1)) )) (defun html/parse-length-list (s) From dlichteblau at common-lisp.net Tue Jan 2 14:30:11 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Tue, 2 Jan 2007 09:30:11 -0500 (EST) Subject: [closure-cvs] CVS closure Message-ID: <20070102143011.C36164B000@common-lisp.net> Update of /project/closure/cvsroot/closure In directory clnet:/tmp/cvs-serv13003 Modified Files: INSTALL closure.asd Log Message: Use the ZIP library instead of run-shell-command for the zip:// protocol. --- /project/closure/cvsroot/closure/INSTALL 2006/12/31 15:42:40 1.5 +++ /project/closure/cvsroot/closure/INSTALL 2007/01/02 14:30:11 1.6 @@ -17,11 +17,14 @@ [Debian package gif2png] - 4. McCLIM, Closure XML, Bordeaux Threads, and their dependencies + 4. McCLIM, Closure XML, Bordeaux Threads, Flexi-Streams, ZIP + and their dependencies [ http://common-lisp.net/project/mcclim/ http://common-lisp.net/project/cxml/ - http://common-lisp.net/project/bordeaux-threads/ ] + http://common-lisp.net/project/bordeaux-threads/ + http://common-lisp.net/project/zip/ + http://weitz.de/flexi-streams/ ] Compile closure using ASDF: Register closure.asd in your central --- /project/closure/cvsroot/closure/closure.asd 2007/01/02 13:12:57 1.15 +++ /project/closure/cvsroot/closure/closure.asd 2007/01/02 14:30:11 1.16 @@ -87,7 +87,9 @@ :clim-clx :glisp :bordeaux-threads - :trivial-sockets) + :trivial-sockets + :zip + :flexi-streams) :default-component-class closure-source-file :components ((:module src From dlichteblau at common-lisp.net Tue Jan 2 14:30:12 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Tue, 2 Jan 2007 09:30:12 -0500 (EST) Subject: [closure-cvs] CVS closure/src/net Message-ID: <20070102143012.07C404D004@common-lisp.net> Update of /project/closure/cvsroot/closure/src/net In directory clnet:/tmp/cvs-serv13003/src/net Modified Files: http.lisp Log Message: Use the ZIP library instead of run-shell-command for the zip:// protocol. --- /project/closure/cvsroot/closure/src/net/http.lisp 2007/01/02 13:13:03 1.11 +++ /project/closure/cvsroot/closure/src/net/http.lisp 2007/01/02 14:30:11 1.12 @@ -959,39 +959,33 @@ ;; ;; Back to what is actually implemented. To read a document from within a zip -;; archive, we simply pass the request to the `unzip' command. So you must -;; have installed this for a working zip protocol. +;; archive, we simply use the ZIP library. So you must have it installed +;; for a working zip protocol. ;; TODO ;; - detect non-existing archives and non-existing archive documents. ;; - when no archive file name is given, attempt to format the zip file ;; directory as HTML, to be able to inspect the zip file. -;; - detect the non-existence of the `unzip' command and give a reasonable -;; error message. (defun open-zip-document (url) - (multiple-value-bind (zip-archive-pathname archive-component-file-name) (split-zip-url url) - (cond ((null zip-archive-pathname) - (error "Bad zip url: ~S" url)) - (t - (with-temporary-file (temp-filename) - (let ((res (run-unix-shell-command (format nil "unzip -p ~A ~A >~A" - (namestring zip-archive-pathname) - archive-component-file-name - temp-filename)))) - (cond ((zerop res) - (values - (cl-byte-stream->gstream (open temp-filename - :direction :input - :element-type '(unsigned-byte 8))) - (list (cons "Content-Type" - (let ((mt (find-mime-type-from-extension - (url-extension url)))) - (if mt - (mime-type-name mt) - "text/plain")))))) - (t - (error "unzip failed on ~S" url)) ))))))) + (multiple-value-bind (zip-archive-pathname archive-component-file-name) + (split-zip-url url) + (cond + ((null zip-archive-pathname) + (error "Bad zip url: ~S" url)) + (t + (values + (cl-byte-stream->gstream + (flexi-streams:make-in-memory-input-stream + (zip:with-zipfile (zip zip-archive-pathname) + (zip:zipfile-entry-contents + (zip:get-zipfile-entry archive-component-file-name zip))))) + (list (cons "Content-Type" + (let ((mt (find-mime-type-from-extension + (url-extension url)))) + (if mt + (mime-type-name mt) + "text/plain"))))))))) (defun split-zip-url (url) ;; -> zip-archive-pathname ; archive-component-file-name From emarsden at common-lisp.net Wed Jan 3 11:34:45 2007 From: emarsden at common-lisp.net (emarsden) Date: Wed, 3 Jan 2007 06:34:45 -0500 (EST) Subject: [closure-cvs] CVS closure/src/glisp Message-ID: <20070103113445.91E8E39063@common-lisp.net> Update of /project/closure/cvsroot/closure/src/glisp In directory clnet:/tmp/cvs-serv1214/src/glisp Modified Files: dep-sbcl.lisp Log Message: GUI: implement beginning-of-page and end-of-page commands; add keyboard shortcuts for back & forward. --- /project/closure/cvsroot/closure/src/glisp/dep-sbcl.lisp 2007/01/02 13:12:58 1.8 +++ /project/closure/cvsroot/closure/src/glisp/dep-sbcl.lisp 2007/01/03 11:34:45 1.9 @@ -33,7 +33,7 @@ (apply #'read-sequence ap)) (defmacro glisp::with-timeout ((&rest options) &body body) - (declare (ignore ignore)) + (declare (ignore options)) `(progn , at body)) From emarsden at common-lisp.net Wed Jan 3 11:34:45 2007 From: emarsden at common-lisp.net (emarsden) Date: Wed, 3 Jan 2007 06:34:45 -0500 (EST) Subject: [closure-cvs] CVS closure/src/gui Message-ID: <20070103113445.D44113A018@common-lisp.net> Update of /project/closure/cvsroot/closure/src/gui In directory clnet:/tmp/cvs-serv1214/src/gui Modified Files: clim-gui.lisp Log Message: GUI: implement beginning-of-page and end-of-page commands; add keyboard shortcuts for back & forward. --- /project/closure/cvsroot/closure/src/gui/clim-gui.lisp 2006/12/31 15:42:40 1.27 +++ /project/closure/cvsroot/closure/src/gui/clim-gui.lisp 2007/01/03 11:34:45 1.28 @@ -4,7 +4,7 @@ ;;; Created: 2002-07-22 ;;; Author: Gilbert Baumann ;;; License: MIT style (see below) -;;; $Id: clim-gui.lisp,v 1.27 2006/12/31 15:42:40 dlichteblau Exp $ +;;; $Id: clim-gui.lisp,v 1.28 2007/01/03 11:34:45 emarsden Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2002 by Gilbert Baumann @@ -28,7 +28,12 @@ ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;; $Log: clim-gui.lisp,v $ +;; Revision 1.28 2007/01/03 11:34:45 emarsden +;; GUI: implement beginning-of-page and end-of-page commands; add +;; keyboard shortcuts for back & forward. +;; ;; Revision 1.27 2006/12/31 15:42:40 dlichteblau +;; ;; Use Bordeaux Threads for all threading primitives, so that non-GUI parts of ;; Closure don't have to depend on CLIM anymore. ;; @@ -364,7 +369,7 @@ (define-closure-command (com-reflow :name t) () (reflow)) -(define-closure-command (com-back :name t) () +(define-closure-command (com-back :name t :keystroke (:left :control)) () (let ((*standard-output* *query-io*)) (cond ((null (cdr *back-history*)) (format t "There is nowhere you can go back to.~%")) @@ -373,8 +378,8 @@ (format t "Going back to ~S.~%" (first *back-history*)) (foo (first *back-history*)))))) -(define-closure-command (com-forward :name t) () - (let ((*standard-output* *query-io*)) +(define-closure-command (com-forward :name t :keystroke (:right :control)) () + (let ((*standard-output* *query-io*)) (cond ((null *forw-history*) (format t "There is nowhere you can go forward to.~%")) (t @@ -398,7 +403,7 @@ (setf gui:*user-wants-images-p* t) (format *query-io* "Images are now on. You may want to reload.~%")) -(define-closure-command (com-quit :name t) () +(define-closure-command (com-quit :name t :keystroke (#\q :control)) () (frame-exit *application-frame*)) (defun make-google-search-url (string) @@ -561,9 +566,8 @@ (lambda () (with-simple-restart (forget "Just forget rendering this page.") (let* ((*package* (find-package :r2)) - (*pane* (find-pane-named *frame* 'canvas)) - (*medium* (sheet-medium *pane*))) - (progn ;; with-sheet-medium (*medium* *pane*) + (*pane* (find-pane-named *frame* 'canvas))) + (with-sheet-medium (*medium* *pane*) (let ((device (make-instance 'closure/clim-device::clim-device :medium *pane*))) (setf (sheet-pointer-cursor *pane*) :busy) (setq url (r2::parse-url* url)) @@ -664,13 +668,12 @@ (setq gui:*zoom-factor* 1.0) (send-closure-command 'com-reflow)) -;; FIXME the :shift here is a McCLIM bug -(define-closure-command (com-zoom-in :name t :keystroke (#\+ :control :shift)) () +(define-closure-command (com-zoom-in :name t :keystroke (#\+ :control)) () (write-status "Zooming in...") (setq gui:*zoom-factor* (* gui:*zoom-factor* 1.2)) (send-closure-command 'com-reflow)) -(define-closure-command (com-zoom-out :name t :keystroke (#\- :control :shift)) () +(define-closure-command (com-zoom-out :name t :keystroke (#\- :control)) () (write-status "Zooming out...") (setq gui:*zoom-factor* (* gui:*zoom-factor* 0.8)) (send-closure-command 'com-reflow)) @@ -692,6 +695,18 @@ (scroll-extent pane 0 (min (gadget-max-value scrollbar) (+ current-y (* 0.9 window-height)))))) +(define-closure-command (com-beginning-of-page :name t + :keystroke (:home :control)) () + (let* ((pane (find-pane-named *frame* 'canvas)) + (scrollbar (slot-value (pane-scroller pane) 'climi::vscrollbar))) + (scroll-extent pane 0 (gadget-min-value scrollbar)))) + +(define-closure-command (com-end-of-page :name t + :keystroke (:end :control)) () + (let* ((pane (find-pane-named *frame* 'canvas)) + (scrollbar (slot-value (pane-scroller pane) 'climi::vscrollbar))) + (scroll-extent pane 0 (gadget-max-value scrollbar)))) + (define-closure-command (com-redraw :name t :keystroke (#\r :control)) () (let* ((*pane* (find-pane-named *frame* 'canvas)) ) (handle-repaint *pane* (sheet-region (pane-viewport *pane*)))) From emarsden at common-lisp.net Wed Jan 3 15:39:28 2007 From: emarsden at common-lisp.net (emarsden) Date: Wed, 3 Jan 2007 10:39:28 -0500 (EST) Subject: [closure-cvs] CVS closure Message-ID: <20070103153928.0665B2B139@common-lisp.net> Update of /project/closure/cvsroot/closure In directory clnet:/tmp/cvs-serv29995 Modified Files: closure.asd Log Message: Load GIF images using the Skippy library, instead of the external application gif2png. Reorganize the image code in the process. --- /project/closure/cvsroot/closure/closure.asd 2007/01/02 14:30:11 1.16 +++ /project/closure/cvsroot/closure/closure.asd 2007/01/03 15:39:28 1.17 @@ -89,7 +89,8 @@ :bordeaux-threads :trivial-sockets :zip - :flexi-streams) + :flexi-streams + :skippy) :default-component-class closure-source-file :components ((:module src @@ -99,7 +100,7 @@ (:module patches :components ((:file "clx-patch"))) - + ;; Images (:module imagelib @@ -108,12 +109,14 @@ ((:file "package") (:file "basic") (:file "deflate") - (:file "png"))) + (:file "png") + (:file "gif") + (:file "jpeg"))) ;; Early package definitions (:file "defpack") - + ;; Closure Protocol Declarations first (:module protocols From emarsden at common-lisp.net Wed Jan 3 15:39:29 2007 From: emarsden at common-lisp.net (emarsden) Date: Wed, 3 Jan 2007 10:39:29 -0500 (EST) Subject: [closure-cvs] CVS closure/src/imagelib Message-ID: <20070103153929.3FD0439063@common-lisp.net> Update of /project/closure/cvsroot/closure/src/imagelib In directory clnet:/tmp/cvs-serv29995/src/imagelib Modified Files: package.lisp basic.lisp Log Message: Load GIF images using the Skippy library, instead of the external application gif2png. Reorganize the image code in the process. --- /project/closure/cvsroot/closure/src/imagelib/package.lisp 2006/12/31 11:48:18 1.4 +++ /project/closure/cvsroot/closure/src/imagelib/package.lisp 2007/01/03 15:39:29 1.5 @@ -39,10 +39,10 @@ #:aimage-plist #:make-aimage #:scale-aimage - #:pnm-stream->aimage)) - -(defpackage :imagelib.gif - (:use :cl :glisp :imagelib)) + #:gif-stream->aimage + #:jpeg-stream->aimage + #:pnm-stream->aimage + #:any->aimage-by-filter)) (defpackage :png (:use :cl :glisp :imagelib) --- /project/closure/cvsroot/closure/src/imagelib/basic.lisp 2005/03/13 18:02:00 1.3 +++ /project/closure/cvsroot/closure/src/imagelib/basic.lisp 2007/01/03 15:39:29 1.4 @@ -297,3 +297,83 @@ :alpha-p nil))) +(defun any->aimage-by-filter (filter-name input) + (with-temporary-file (temp-filename) + (with-temporary-file (pnm-filename) + (with-open-file (sink temp-filename + :direction :output + :if-exists :overwrite + :element-type '(unsigned-byte 8)) + (let ((sink (make-instance 'glisp:cl-byte-stream :cl-stream sink))) + (let ((tmp (make-array 4096 :element-type '(unsigned-byte 8)))) + (do ((n (g/read-byte-sequence tmp input) + (g/read-byte-sequence tmp input))) + ((= n 0)) + (g/write-byte-sequence tmp sink :end n))))) + (let ((cmd (format nil "~A <~A >~A" filter-name + (namestring (truename temp-filename)) + (namestring pnm-filename)))) + (format *debug-io* "~%;; running: ~A" cmd) + (run-unix-shell-command cmd)) + (progn ;ignore-errors + (with-open-file (input pnm-filename + :direction :input + :element-type '(unsigned-byte 8)) + (pnm-stream->aimage + (make-instance 'cl-byte-stream :cl-stream input)))) ))) + + +;;; Image writers + +(defun write-ppm-image (aimage sink) + ;; We write P3/P6 images + (let ((binary-p (subtypep (stream-element-type sink) '(unsigned-byte 8)))) + (let ((header + (with-output-to-string (bag) + (format bag "~A~%" (if binary-p "P6" "P3")) + (format bag "~D ~D ~D" (aimage-width aimage) (aimage-height aimage) 255)))) + (if binary-p + (write-sequence (map '(array (unsigned-byte 8) (*)) #'char-code header) sink) + (write-string header sink)) + (cond (binary-p + (write-byte 10 sink) + (let ((buffer (make-array (* 3 (aimage-width aimage)) :element-type '(unsigned-byte 8))) + (width (aimage-width aimage)) + (data (aimage-data aimage)) + (i 0)) + (declare (type (simple-array (unsigned-byte 8) (*)) buffer) + (type (array (unsigned-byte 32) (* *)) data) + (type fixnum width) + (type fixnum i)) + (dotimes (y (aimage-height aimage)) + (setf i 0) + (do ((x 0 (the fixnum (+ x 1)))) + ((= x width)) + (declare (type fixnum x)) + (let ((byte (aref data y x))) + (declare (type (unsigned-byte 8) byte)) + (setf (aref buffer i) (ldb (byte 8 0) byte)) + (setf i (the fixnum (+ i 1))) + (setf (aref buffer i) (ldb (byte 8 8) byte)) + (setf i (the fixnum (+ i 1))) + (setf (aref buffer i) (ldb (byte 8 16) byte)) + (setf i (the fixnum (+ i 1))))) + (write-sequence buffer sink)))) + (t + (dotimes (y (aimage-height aimage)) + (dotimes (x (aimage-width aimage)) + (when (= (mod x 4) 0) + (terpri sink)) + (let ((byte (aref (aimage-data aimage) y x))) + (format sink " ~D ~D ~D" + (ldb (byte 8 0) byte) + (ldb (byte 8 8) byte) + (ldb (byte 8 16) byte)) ))) + (terpri sink)))))) + +(defun blu (aimage) + (with-open-file (sink "/tmp/a.ppm" + :direction :output + :if-exists :new-version + :element-type '(unsigned-byte 8)) + (write-ppm-image aimage sink))) From emarsden at common-lisp.net Wed Jan 3 15:39:29 2007 From: emarsden at common-lisp.net (emarsden) Date: Wed, 3 Jan 2007 10:39:29 -0500 (EST) Subject: [closure-cvs] CVS closure/src/renderer Message-ID: <20070103153929.7048539063@common-lisp.net> Update of /project/closure/cvsroot/closure/src/renderer In directory clnet:/tmp/cvs-serv29995/src/renderer Modified Files: images.lisp Log Message: Load GIF images using the Skippy library, instead of the external application gif2png. Reorganize the image code in the process. --- /project/closure/cvsroot/closure/src/renderer/images.lisp 2005/07/17 09:38:54 1.3 +++ /project/closure/cvsroot/closure/src/renderer/images.lisp 2007/01/03 15:39:29 1.4 @@ -111,128 +111,14 @@ ((eq mime-type (netlib:find-mime-type "image/png")) (png:png-stream->aimage input)) ((eq mime-type (netlib:find-mime-type "image/gif")) - (let ((*print-array* nil)) - (gif-stream->aimage input))) - - ;; The rest simply goes to the appropriate ->ppm filters. + (imagelib:gif-stream->aimage input)) ((eq mime-type (netlib:find-mime-type "image/jpeg")) - (any->aimage-by-filter "djpeg" input)) + (imagelib:jpeg-stream->aimage input)) + ;; The rest simply goes to the appropriate ->ppm filters. ((eq mime-type (netlib:find-mime-type "image/x-xbitmap")) - (any->aimage-by-filter "xbmtopbm" input)) + (imagelib:any->aimage-by-filter "xbmtopbm" input)) ((eq mime-type (netlib:find-mime-type "image/x-xpixmap")) - (any->aimage-by-filter "xpmtoppm" input)) + (imagelib:any->aimage-by-filter "xpmtoppm" input)) ((eq mime-type (netlib:find-mime-type "image/tiff")) - (any->aimage-by-filter "tifftopnm" input)))) - -(defun gif-stream->aimage (input) - (with-temporary-file (temp-filename) - (let ((png-filename (merge-pathnames (make-pathname :type "png") - temp-filename))) - (with-open-file (sink temp-filename - :direction :output - :if-exists :overwrite - :element-type '(unsigned-byte 8)) - (let ((sink (make-instance 'glisp:cl-byte-stream :cl-stream sink))) - (let ((tmp (make-array 4096 :element-type '(unsigned-byte 8)))) - (do ((n (g/read-byte-sequence tmp input) - (g/read-byte-sequence tmp input))) - ((= n 0)) - (g/write-byte-sequence tmp sink :end n))))) - (unwind-protect - (progn - (run-unix-shell-command - (format nil "gif2png -r ~A >/dev/null 2>/dev/null" - (namestring (truename temp-filename)))) - (with-open-file (input png-filename - :direction :input - :element-type '(unsigned-byte 8)) - (let ((i (make-instance 'cl-byte-stream :cl-stream input))) - (png:png-stream->aimage i)))) - (ignore-errors - (mapc #'(lambda (x) (ignore-errors (delete-file x))) - (directory (merge-pathnames (make-pathname :type :wild) - temp-filename)))) )))) - -#+NIL -(defun gif-stream->aimage (input) - (imagelib.gif::read-gif-image input)) - -(defun any->aimage-by-filter (filter-name input) - (with-temporary-file (temp-filename) - (with-temporary-file (pnm-filename) - (with-open-file (sink temp-filename - :direction :output - :if-exists :overwrite - :element-type '(unsigned-byte 8)) - (let ((sink (make-instance 'glisp:cl-byte-stream :cl-stream sink))) - (let ((tmp (make-array 4096 :element-type '(unsigned-byte 8)))) - (do ((n (g/read-byte-sequence tmp input) - (g/read-byte-sequence tmp input))) - ((= n 0)) - (g/write-byte-sequence tmp sink :end n))))) - (let ((cmd (format nil "~A <~A >~A" filter-name - (namestring (truename temp-filename)) - (namestring pnm-filename)))) - (format *debug-io* "~%;; running: ~A" cmd) - (run-unix-shell-command cmd)) - (progn ;ignore-errors - (with-open-file (input pnm-filename - :direction :input - :element-type '(unsigned-byte 8)) - (pnm-stream->aimage - (make-instance 'cl-byte-stream :cl-stream input)))) ))) - -;;; Image writers - -(defun write-ppm-image (aimage sink) - ;; We write P3/P6 images - (let ((binary-p (subtypep (stream-element-type sink) '(unsigned-byte 8)))) - (let ((header - (with-output-to-string (bag) - (format bag "~A~%" (if binary-p "P6" "P3")) - (format bag "~D ~D ~D" (aimage-width aimage) (aimage-height aimage) 255)))) - (if binary-p - (write-sequence (map '(array (unsigned-byte 8) (*)) #'char-code header) sink) - (write-string header sink)) - (cond (binary-p - (write-byte 10 sink) - (let ((buffer (make-array (* 3 (aimage-width aimage)) :element-type '(unsigned-byte 8))) - (width (aimage-width aimage)) - (data (aimage-data aimage)) - (i 0)) - (declare (type (simple-array (unsigned-byte 8) (*)) buffer) - (type (array (unsigned-byte 32) (* *)) data) - (type fixnum width) - (type fixnum i)) - (dotimes (y (aimage-height aimage)) - (setf i 0) - (do ((x 0 (the fixnum (+ x 1)))) - ((= x width)) - (declare (type fixnum x)) - (let ((byte (aref data y x))) - (declare (type (unsigned-byte 8) byte)) - (setf (aref buffer i) (ldb (byte 8 0) byte)) - (setf i (the fixnum (+ i 1))) - (setf (aref buffer i) (ldb (byte 8 8) byte)) - (setf i (the fixnum (+ i 1))) - (setf (aref buffer i) (ldb (byte 8 16) byte)) - (setf i (the fixnum (+ i 1))))) - (write-sequence buffer sink)))) - (t - (dotimes (y (aimage-height aimage)) - (dotimes (x (aimage-width aimage)) - (when (= (mod x 4) 0) - (terpri sink)) - (let ((byte (aref (aimage-data aimage) y x))) - (format sink " ~D ~D ~D" - (ldb (byte 8 0) byte) - (ldb (byte 8 8) byte) - (ldb (byte 8 16) byte)) ))) - (terpri sink)))))) + (imagelib:any->aimage-by-filter "tifftopnm" input)))) -(defun blu (aimage) - (with-open-file (sink "/tmp/a.ppm" - :direction :output - :if-exists :new-version - :element-type '(unsigned-byte 8)) - (write-ppm-image aimage sink))) From emarsden at common-lisp.net Wed Jan 3 16:07:25 2007 From: emarsden at common-lisp.net (emarsden) Date: Wed, 3 Jan 2007 11:07:25 -0500 (EST) Subject: [closure-cvs] CVS closure/src/parse Message-ID: <20070103160725.F0F1221013@common-lisp.net> Update of /project/closure/cvsroot/closure/src/parse In directory clnet:/tmp/cvs-serv3355/src/parse Modified Files: pt.lisp Log Message: Reimplement the LHTML parser. The previous version could not handle forms like ((:a :href "/foo.html") "foo"). --- /project/closure/cvsroot/closure/src/parse/pt.lisp 2006/12/31 13:24:49 1.5 +++ /project/closure/cvsroot/closure/src/parse/pt.lisp 2007/01/03 16:07:25 1.6 @@ -148,7 +148,7 @@ (setf (pt-parent k) res)) res)) -(defun ppt (pt &optional (prefix "") (barp nil)) +(defun ppt (pt &optional (stream *standard-output*) (prefix "") (barp nil)) (cond ((eq (pt-name pt) :pcdata) (let ((s (map 'string #'(lambda (x) @@ -162,15 +162,16 @@ (setq s (concatenate 'string (subseq s 0 (- 120 (length prefix)))) flag t)) (write-string (format nil "~%~A| ~S ~A" prefix s - (if flag "..." ""))))) + (if flag "..." "")) stream))) (t - (write-string (format nil "~%~A| ~A" prefix (pt-name pt))) + (write-string (format nil "~%~A| ~A" prefix (pt-name pt)) stream) (when (pt-children pt) (write-string (format nil "~%~A~A-~A." prefix (if barp "+" "`") (make-string (length (symbol-name (pt-name pt))) - :initial-element #\- ))) + :initial-element #\- )) + stream) (let ((prefix1 (concatenate 'string prefix (if barp "|" " ") (make-string (length (symbol-name (pt-name pt))) @@ -178,7 +179,7 @@ " "))) (do ((q (pt-children pt) (cdr q))) ((null q)) - (ppt (car q) prefix1 (if (cdr q) 't 'nil)))))))) + (ppt (car q) stream prefix1 (if (cdr q) 't 'nil)))))))) ;;; ------------------------------------------------------------------------------------------- @@ -218,27 +219,33 @@ (cond ((null pt) nil) ((cons (pt-name pt) (pt-full-name-path (pt-parent pt)))))) -(defun lhtml->pt (tree) - (cond ((typep tree 'rod) - (sgml::make-pt :name :pcdata :attrs tree)) - ((stringp tree) - (sgml::make-pt :name :pcdata :attrs (string-rod tree))) - ((sgml::pt-p tree) tree) - ((and (consp tree) (keywordp (car tree))) - (let ((attrs nil) - (gi (car tree))) - (do ((q (cdr tree) (cddr q))) - ((or (null q) - (not (keywordp (car q)))) - (sgml::make-pt :name gi - :attrs (nreverse attrs) - :children (mapcar #'lhtml->pt q))) - (push (car q) attrs) - (push (rod (cadr q)) attrs)))) - (t - (error "~S does not look like LHTML." tree)) )) +(defun walk-lhtml (lhtml tag-callback text-callback) + (if (stringp lhtml) + (funcall text-callback lhtml) + (destructuring-bind (tag &rest body) + (if (consp lhtml) lhtml (list lhtml)) + (destructuring-bind (tag-name &rest attributes) + (if (consp tag) tag (list tag)) + (funcall tag-callback tag-name attributes body))))) + +(defun lhtml->pt (lhtml) + (walk-lhtml lhtml + ;; tag callback + (lambda (tag-name attributes body) + (make-pt :name tag-name + :attrs (loop :for (key value) :on attributes :by #'cddr + :collect key + :collect (etypecase value + (string (runes:string-rod value)) + (sgml::rod value))) + :children (mapcar #'lhtml->pt body))) + ;; text callback + (lambda (string) + (assert (stringp string)) + (make-pt :name :pcdata :attrs (runes:string-rod string))))) (defun lhtml-reader (stream subchar arg) + (declare (ignore subchar arg)) `(lhtml->pt ,(funcall (get-macro-character #\`) stream nil))) From emarsden at common-lisp.net Wed Jan 3 16:09:13 2007 From: emarsden at common-lisp.net (emarsden) Date: Wed, 3 Jan 2007 11:09:13 -0500 (EST) Subject: [closure-cvs] CVS closure/src/imagelib Message-ID: <20070103160913.ECBFF21013@common-lisp.net> Update of /project/closure/cvsroot/closure/src/imagelib In directory clnet:/tmp/cvs-serv3503 Added Files: gif.lisp jpeg.lisp Log Message: New files for the "organic" GIF support. --- /project/closure/cvsroot/closure/src/imagelib/gif.lisp 2007/01/03 16:09:13 NONE +++ /project/closure/cvsroot/closure/src/imagelib/gif.lisp 2007/01/03 16:09:13 1.1 ;;; gif.lisp --- render GIF files in Closure ;;; ;;; Author: Eric Marsden ;; ;; ;; Read GIF files using the Skippy library ;; (http://www.xach.com/lisp/skippy/) and convert them to Closure's ;; internal AIMAGE format. (in-package :imagelib) (defgeneric flexi-stream-from (thing)) (defmethod flexi-stream-from ((thing cl:pathname)) (let ((data (make-array 1024 :element-type '(unsigned-byte 8) :fill-pointer 0 :adjustable t))) (with-open-file (in thing :direction :input :element-type '(unsigned-byte 8)) (loop :for b = (read-byte in nil nil) :while b :do (vector-push-extend b data))) (flexi-streams:make-in-memory-input-stream data))) (defmethod flexi-stream-from ((gstream glisp:gstream)) (let ((data (make-array 1024 :element-type '(unsigned-byte 8) :fill-pointer 0 :adjustable t))) (loop :for b = (g/read-byte gstream nil nil) :while b :do (vector-push-extend b data)) (g/close gstream) (flexi-streams:make-in-memory-input-stream data))) (defmethod flexi-stream-from ((stream flexi-streams:flexi-stream)) stream) (defmethod flexi-stream-from ((stream flexi-streams:in-memory-stream)) stream) (defun gif-stream->aimage (stream) (let* ((data-stream (skippy:read-data-stream (flexi-stream-from stream))) (image (skippy:last-image data-stream)) (gif-color-table (skippy:color-table data-stream)) (aimage (make-aimage (skippy:width image) (skippy:height image) :alpha-p nil)) (aimage-data (aimage-data aimage))) (dotimes (x (skippy:width image)) (dotimes (y (skippy:height image)) (multiple-value-bind (r g b) (skippy:color-rgb (skippy:color-table-entry gif-color-table (skippy:pixel-ref image x y))) (setf (aref aimage-data y x) (dpb r (byte 8 0) (dpb g (byte 8 8) (dpb b (byte 8 16) (dpb (- 255 0) (byte 8 24) 0)))))))) aimage)) ;; this is the historical version of GIF-STREAM->AIMAGE, that calls ;; the external program gif2png (defun gif-stream->aimage/gif2png (input) (with-temporary-file (temp-filename) (let ((png-filename (merge-pathnames (make-pathname :type "png") temp-filename))) (with-open-file (sink temp-filename :direction :output :if-exists :overwrite :element-type '(unsigned-byte 8)) (let ((sink (make-instance 'glisp:cl-byte-stream :cl-stream sink))) (let ((tmp (make-array 4096 :element-type '(unsigned-byte 8)))) (do ((n (g/read-byte-sequence tmp input) (g/read-byte-sequence tmp input))) ((= n 0)) (g/write-byte-sequence tmp sink :end n))))) (unwind-protect (progn (run-unix-shell-command (format nil "gif2png -r ~A >/dev/null 2>/dev/null" (namestring (truename temp-filename)))) (with-open-file (input png-filename :direction :input :element-type '(unsigned-byte 8)) (let ((i (make-instance 'cl-byte-stream :cl-stream input))) (png:png-stream->aimage i)))) (ignore-errors (mapc #'(lambda (x) (ignore-errors (delete-file x))) (directory (merge-pathnames (make-pathname :type :wild) temp-filename)))) )))) ;; EOF --- /project/closure/cvsroot/closure/src/imagelib/jpeg.lisp 2007/01/03 16:09:13 NONE +++ /project/closure/cvsroot/closure/src/imagelib/jpeg.lisp 2007/01/03 16:09:13 1.1 ;;; jpeg.lisp -- render JPEG files in Closure ;;; ;;; Author: Eric Marsden ;; ;; ;; This will soon be replaced by an implementation based on cl-jpeg. (in-package :imagelib) (defun jpeg-stream->aimage (input) (any->aimage-by-filter "djpeg" input)) ;; EOF From emarsden at common-lisp.net Wed Jan 3 16:14:57 2007 From: emarsden at common-lisp.net (emarsden) Date: Wed, 3 Jan 2007 11:14:57 -0500 (EST) Subject: [closure-cvs] CVS closure/src/gui Message-ID: <20070103161457.AB1B121013@common-lisp.net> Update of /project/closure/cvsroot/closure/src/gui In directory clnet:/tmp/cvs-serv3885/src/gui Modified Files: clim-gui.lisp Log Message: - new function RENDER-LHTML that renders LHTML - new command "Inspect Page" that runs Clouseau on the current document --- /project/closure/cvsroot/closure/src/gui/clim-gui.lisp 2007/01/03 11:34:45 1.28 +++ /project/closure/cvsroot/closure/src/gui/clim-gui.lisp 2007/01/03 16:14:57 1.29 @@ -4,7 +4,7 @@ ;;; Created: 2002-07-22 ;;; Author: Gilbert Baumann ;;; License: MIT style (see below) -;;; $Id: clim-gui.lisp,v 1.28 2007/01/03 11:34:45 emarsden Exp $ +;;; $Id: clim-gui.lisp,v 1.29 2007/01/03 16:14:57 emarsden Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2002 by Gilbert Baumann @@ -28,6 +28,10 @@ ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;; $Log: clim-gui.lisp,v $ +;; Revision 1.29 2007/01/03 16:14:57 emarsden +;; - new function RENDER-LHTML that renders LHTML +;; - new command "Inspect Page" that runs Clouseau on the current document +;; ;; Revision 1.28 2007/01/03 11:34:45 emarsden ;; GUI: implement beginning-of-page and end-of-page commands; add ;; keyboard shortcuts for back & forward. @@ -344,6 +348,31 @@ (define-presentation-type r2::pt ()) (define-presentation-type r2::hyper-link ()) +;; renders LHTML as per http://opensource.franz.com/xmlutils/xmlutils-dist/phtml.htm +(defun render-lhtml (location lhtml) + (with-simple-restart (forget "Just forget rendering this page.") + (let* ((*package* (find-package :r2)) + (*pane* (find-pane-named *frame* 'canvas)) + (*medium* (sheet-medium *pane*)) + (device (make-instance 'closure/clim-device::clim-device :medium *pane*)) + (doc (make-instance 'r2::document + :processes-hooks nil + :location location + :http-header nil + :pt (sgml::lhtml->pt lhtml))) + (*current-document* doc) + (closure-protocol:*user-agent* nil) + (closure-protocol:*document-language* (make-instance 'r2::html-4.0-document-language)) + (r2::*canvas-width* (bounding-rectangle-width (sheet-parent *pane*)))) + (window-clear *pane*) + (closure-protocol:render closure-protocol:*document-language* + doc + device + (setf *current-pt* (r2::document-pt doc)) + 600 t 0) + (clim-backend:port-force-output (find-port)) + (reflow)))) + ;;;; ---------------------------------------------------------------------------------------------------- ;;;; Commands ;;;; @@ -722,5 +751,12 @@ (setq renderer:*hyphenate-p* nil) (send-closure-command 'com-reflow)) +;; for Closure developers +(define-closure-command (com-inspect-page :name t) () + (write-status "Loading Clouseau") + (asdf:oos 'asdf:load-op :clouseau) + (write-status "Starting inspector") + (funcall (find-symbol "INSPECTOR" :clouseau) *current-document* :new-process t)) + ;; EOF From emarsden at common-lisp.net Wed Jan 3 16:41:15 2007 From: emarsden at common-lisp.net (emarsden) Date: Wed, 3 Jan 2007 11:41:15 -0500 (EST) Subject: [closure-cvs] CVS closure/src/imagelib Message-ID: <20070103164115.AF9BE39064@common-lisp.net> Update of /project/closure/cvsroot/closure/src/imagelib In directory clnet:/tmp/cvs-serv7799/src/imagelib Modified Files: gif.lisp Log Message: Implement transparency support for GIF files (thanks to Zachary Beane for diagnosing the problem). --- /project/closure/cvsroot/closure/src/imagelib/gif.lisp 2007/01/03 16:09:13 1.1 +++ /project/closure/cvsroot/closure/src/imagelib/gif.lisp 2007/01/03 16:41:15 1.2 @@ -43,20 +43,24 @@ (defun gif-stream->aimage (stream) (let* ((data-stream (skippy:read-data-stream (flexi-stream-from stream))) (image (skippy:last-image data-stream)) + (transparent-index (skippy:transparency-index image)) (gif-color-table (skippy:color-table data-stream)) (aimage (make-aimage (skippy:width image) - (skippy:height image) :alpha-p nil)) + (skippy:height image) :alpha-p transparent-index)) (aimage-data (aimage-data aimage))) (dotimes (x (skippy:width image)) (dotimes (y (skippy:height image)) - (multiple-value-bind (r g b) - (skippy:color-rgb - (skippy:color-table-entry gif-color-table (skippy:pixel-ref image x y))) + (multiple-value-bind (r g b a) + (let ((color-index (skippy:pixel-ref image x y))) + (if (eql color-index transparent-index) + (values 0 0 0 255) + (skippy:color-rgb + (skippy:color-table-entry gif-color-table color-index)))) (setf (aref aimage-data y x) (dpb r (byte 8 0) (dpb g (byte 8 8) (dpb b (byte 8 16) - (dpb (- 255 0) (byte 8 24) 0)))))))) + (dpb (or a 0) (byte 8 24) 0)))))))) aimage)) From emarsden at common-lisp.net Thu Jan 4 23:46:25 2007 From: emarsden at common-lisp.net (emarsden) Date: Thu, 4 Jan 2007 18:46:25 -0500 (EST) Subject: [closure-cvs] CVS closure Message-ID: <20070104234625.AD55C690DD@common-lisp.net> Update of /project/closure/cvsroot/closure In directory clnet:/tmp/cvs-serv12710 Modified Files: closure.asd Log Message: Cleanups. --- /project/closure/cvsroot/closure/closure.asd 2007/01/03 15:39:28 1.17 +++ /project/closure/cvsroot/closure/closure.asd 2007/01/04 23:46:25 1.18 @@ -159,7 +159,7 @@ ((:file "package") (:file "pt" :depends-on ("package")) (:file "sgml-dtd" :depends-on ("package")) - (:file "sgml-parse" :depends-on ("package" "sgml-dtd")) )) + (:file "sgml-parse" :depends-on ("package" "sgml-dtd" "pt")) )) ;; More Random Utilities From emarsden at common-lisp.net Thu Jan 4 23:46:26 2007 From: emarsden at common-lisp.net (emarsden) Date: Thu, 4 Jan 2007 18:46:26 -0500 (EST) Subject: [closure-cvs] CVS closure/src/css Message-ID: <20070104234626.2B0466B006@common-lisp.net> Update of /project/closure/cvsroot/closure/src/css In directory clnet:/tmp/cvs-serv12710/src/css Modified Files: css-parse.lisp Log Message: Cleanups. --- /project/closure/cvsroot/closure/src/css/css-parse.lisp 2006/12/31 12:05:33 1.7 +++ /project/closure/cvsroot/closure/src/css/css-parse.lisp 2007/01/04 23:46:25 1.8 @@ -1019,6 +1019,7 @@ (defun parse-style-sheet-from-url (url &key (name "Anonymous Sheet")) (netlib:with-open-document ((input mime-type) url) + (declare (ignore mime-type)) (css:parse-style-sheet input nil :name name :base-url url))) @@ -1118,8 +1119,7 @@ r)))) (defun generate-slot-constants-1 () - (let ((defconstants nil) - (k 0)) + (let ((defconstants nil)) ;; we go to some length to keep the indicies stable ... (let ((props nil) (taken nil)) From emarsden at common-lisp.net Thu Jan 4 23:46:26 2007 From: emarsden at common-lisp.net (emarsden) Date: Thu, 4 Jan 2007 18:46:26 -0500 (EST) Subject: [closure-cvs] CVS closure/src/glisp Message-ID: <20070104234626.686E56D081@common-lisp.net> Update of /project/closure/cvsroot/closure/src/glisp In directory clnet:/tmp/cvs-serv12710/src/glisp Modified Files: dep-cmucl.lisp Log Message: Cleanups. --- /project/closure/cvsroot/closure/src/glisp/dep-cmucl.lisp 2007/01/02 13:12:58 1.8 +++ /project/closure/cvsroot/closure/src/glisp/dep-cmucl.lisp 2007/01/04 23:46:26 1.9 @@ -65,7 +65,7 @@ (apply #'make-array length :element-type 'base-char options)) -(defun glisp:run-unix-shell-command (command) +(defun glisp::run-unix-shell-command (command) (ext:process-exit-code (ext:run-program "/bin/sh" (list "-c" command) :wait t :input nil :output nil))) (defun glisp::getenv (string) From emarsden at common-lisp.net Thu Jan 4 23:46:26 2007 From: emarsden at common-lisp.net (emarsden) Date: Thu, 4 Jan 2007 18:46:26 -0500 (EST) Subject: [closure-cvs] CVS closure/src/parse Message-ID: <20070104234626.9D2EC6D07E@common-lisp.net> Update of /project/closure/cvsroot/closure/src/parse In directory clnet:/tmp/cvs-serv12710/src/parse Modified Files: pt.lisp Log Message: Cleanups. --- /project/closure/cvsroot/closure/src/parse/pt.lisp 2007/01/03 16:07:25 1.6 +++ /project/closure/cvsroot/closure/src/parse/pt.lisp 2007/01/04 23:46:26 1.7 @@ -78,7 +78,6 @@ (pprint k stream))) ;; (pprint-newline :mandatory stream) '(format stream "" (gi object)) )) -||# #-CLISP (defun print-pt (self sink depth) @@ -136,11 +135,7 @@ #'prin1 sink) (write-string ")" sink))))) - - -(defun print-pt (self sink depth) - (declare (ignore depth)) - (format sink "#<~S ~A ..>" (type-of self) (pt-name self))) +||# (defun make-pt (&key name attrs children) (let ((res (make-pt/low :name name :attrs attrs :children children))) From emarsden at common-lisp.net Thu Jan 4 23:46:26 2007 From: emarsden at common-lisp.net (emarsden) Date: Thu, 4 Jan 2007 18:46:26 -0500 (EST) Subject: [closure-cvs] CVS closure/src/renderer Message-ID: <20070104234626.D6AFD6D081@common-lisp.net> Update of /project/closure/cvsroot/closure/src/renderer In directory clnet:/tmp/cvs-serv12710/src/renderer Modified Files: document.lisp Log Message: Cleanups. --- /project/closure/cvsroot/closure/src/renderer/document.lisp 2006/12/31 15:42:41 1.6 +++ /project/closure/cvsroot/closure/src/renderer/document.lisp 2007/01/04 23:46:26 1.7 @@ -157,10 +157,6 @@ ;; STYLE and combine, as if they occured via @import. (let ((sheets nil) (pt (document-pt doc))) - - (setq cl-user::pt pt) - - ;; (dolist (link (document-links doc)) (when (and (style-sheet-link-p link) (style-link-does-apply-p link selected-style) From emarsden at common-lisp.net Thu Jan 4 23:49:13 2007 From: emarsden at common-lisp.net (emarsden) Date: Thu, 4 Jan 2007 18:49:13 -0500 (EST) Subject: [closure-cvs] CVS closure/src/gui Message-ID: <20070104234913.A2FA44818A@common-lisp.net> Update of /project/closure/cvsroot/closure/src/gui In directory clnet:/tmp/cvs-serv12921/src/gui Modified Files: clue-gui.lisp Log Message: Add title to the PT that is generated for image/* and text/plain pages; adapt to new LHTML syntax. --- /project/closure/cvsroot/closure/src/gui/clue-gui.lisp 2006/12/31 15:42:40 1.6 +++ /project/closure/cvsroot/closure/src/gui/clue-gui.lisp 2007/01/04 23:49:13 1.7 @@ -97,15 +97,18 @@ (let ((cs (assoc :charset parameters :test #'string-equal))) (when cs (setf charset (cdr cs)))) - (netlib::find-mime-type (format nil "~A/~A" type subtype))))) + (netlib::find-mime-type (format nil "~A/~A" type subtype)))) + (url-text (url:unparse-url url))) (let ((pt (progn (cond ((member mime-type (list (netlib:find-mime-type "image/png") (netlib:find-mime-type "image/gif") (netlib:find-mime-type "image/jpeg"))) (sgml:lhtml->pt `(:HTML + (:HEAD + (:TITLE ,url-text)) (:BODY - (:IMG :SRC ,(url:unparse-url url)))))) + ((:IMG :SRC ,url-text)))))) ((member mime-type (list (netlib:find-mime-type "text/lml"))) (sgml:lhtml->pt (read-from-string (with-output-to-string (bag) (do ((x (glisp:g/read-byte input nil nil) @@ -123,6 +126,8 @@ (netlib:find-mime-type "text/css")))) (sgml:lhtml->pt `(:HTML + (:HEAD + (:TITLE ,url-text)) (:BODY (:PRE ,(gstream-as-string input)))))) From crhodes at common-lisp.net Fri Jan 5 11:19:32 2007 From: crhodes at common-lisp.net (crhodes) Date: Fri, 5 Jan 2007 06:19:32 -0500 (EST) Subject: [closure-cvs] CVS closure/src/renderer Message-ID: <20070105111932.04FB372085@common-lisp.net> Update of /project/closure/cvsroot/closure/src/renderer In directory clnet:/tmp/cvs-serv26089/src/renderer Modified Files: renderer2.lisp Log Message: Rune fixes for TeX Mode --- /project/closure/cvsroot/closure/src/renderer/renderer2.lisp 2006/12/30 15:13:55 1.17 +++ /project/closure/cvsroot/closure/src/renderer/renderer2.lisp 2007/01/05 11:19:30 1.18 @@ -4,7 +4,7 @@ ;;; Created: somewhen late 2002 ;;; Author: Gilbert Baumann ;;; License: MIT style (see below) -;;; $Id: renderer2.lisp,v 1.17 2006/12/30 15:13:55 emarsden Exp $ +;;; $Id: renderer2.lisp,v 1.18 2007/01/05 11:19:30 crhodes Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 1997-2003 by Gilbert Baumann @@ -4823,8 +4823,8 @@ (let ((data (black-chunk-data x))) (loop for j from 0 for c across data do - (cond ((or (<= #/a c #/z) - (<= #/A c #/Z)) + (cond ((or (rune<= #/a c #/z) + (rune<= #/A c #/Z)) (push (list i j c) curword)) (t (spill-word)))))) @@ -4836,7 +4836,7 @@ ;; #+NIL (let ((hps nil)) (dolist (word words) - (let* ((s (map 'string (lambda (x) (code-char (third x))) word)) + (let* ((s (map 'string (lambda (x) (rune-char (third x))) word)) (z (hyphen-points (hyphenation-table) s))) (dolist (k (reverse z)) (push (elt word k) hps)))) ;; an assert a day keeps the surprise away. @@ -4983,6 +4983,9 @@ ;; $Log: renderer2.lisp,v $ +;; Revision 1.18 2007/01/05 11:19:30 crhodes +;; Rune fixes for TeX Mode +;; ;; Revision 1.17 2006/12/30 15:13:55 emarsden ;; - use CL from Closure packages ;; - minor rod fixes From emarsden at common-lisp.net Fri Jan 5 23:10:34 2007 From: emarsden at common-lisp.net (emarsden) Date: Fri, 5 Jan 2007 18:10:34 -0500 (EST) Subject: [closure-cvs] CVS closure/src/renderer Message-ID: <20070105231034.0B1E69@common-lisp.net> Update of /project/closure/cvsroot/closure/src/renderer In directory clnet:/tmp/cvs-serv24543 Modified Files: renderer2.lisp Log Message: Fix rendering of preformatted content. --- /project/closure/cvsroot/closure/src/renderer/renderer2.lisp 2007/01/05 11:19:30 1.18 +++ /project/closure/cvsroot/closure/src/renderer/renderer2.lisp 2007/01/05 23:10:33 1.19 @@ -4,7 +4,7 @@ ;;; Created: somewhen late 2002 ;;; Author: Gilbert Baumann ;;; License: MIT style (see below) -;;; $Id: renderer2.lisp,v 1.18 2007/01/05 11:19:30 crhodes Exp $ +;;; $Id: renderer2.lisp,v 1.19 2007/01/05 23:10:33 emarsden Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 1997-2003 by Gilbert Baumann @@ -3086,7 +3086,7 @@ for i fixnum from 0 do (cond ,@(AND (EQL :PRE WHITE-SPACE) - (list `((eql c #/U+0010) + (list `((eql c #/U+000A) (let ((ocontext context)) ,(OR LETTER-SPACING-APPLICABLE-P '(unless (= blacki i) @@ -4983,6 +4983,9 @@ ;; $Log: renderer2.lisp,v $ +;; Revision 1.19 2007/01/05 23:10:33 emarsden +;; Fix rendering of preformatted content. +;; ;; Revision 1.18 2007/01/05 11:19:30 crhodes ;; Rune fixes for TeX Mode ;; From emarsden at common-lisp.net Sun Jan 7 19:32:07 2007 From: emarsden at common-lisp.net (emarsden) Date: Sun, 7 Jan 2007 14:32:07 -0500 (EST) Subject: [closure-cvs] CVS closure/src/gui Message-ID: <20070107193207.09D0C72083@common-lisp.net> Update of /project/closure/cvsroot/closure/src/gui In directory clnet:/tmp/cvs-serv17755 Modified Files: clim-gui.lisp Log Message: Follow HTTP redirects (HTML-level redirects still not supported). --- /project/closure/cvsroot/closure/src/gui/clim-gui.lisp 2007/01/03 16:14:57 1.29 +++ /project/closure/cvsroot/closure/src/gui/clim-gui.lisp 2007/01/07 19:32:06 1.30 @@ -4,7 +4,7 @@ ;;; Created: 2002-07-22 ;;; Author: Gilbert Baumann ;;; License: MIT style (see below) -;;; $Id: clim-gui.lisp,v 1.29 2007/01/03 16:14:57 emarsden Exp $ +;;; $Id: clim-gui.lisp,v 1.30 2007/01/07 19:32:06 emarsden Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2002 by Gilbert Baumann @@ -28,6 +28,9 @@ ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;; $Log: clim-gui.lisp,v $ +;; Revision 1.30 2007/01/07 19:32:06 emarsden +;; Follow HTTP redirects (HTML-level redirects still not supported). +;; ;; Revision 1.29 2007/01/03 16:14:57 emarsden ;; - new function RENDER-LHTML that renders LHTML ;; - new command "Inspect Page" that runs Clouseau on the current document @@ -601,8 +604,13 @@ (setf (sheet-pointer-cursor *pane*) :busy) (setq url (r2::parse-url* url)) (let ((request (clue-gui2::make-request :url url :method :get))) - (multiple-value-bind (io header) (clue-gui2::open-document-4 request) - (write-status "Fetching Document ...") + (write-status "Fetching Document ...") + (multiple-value-bind (io header) + (clue-gui2::open-document-4 request) + (let ((new-location (netlib::get-header-field header :location))) + (when new-location + (unless (string-equal new-location (url:unparse-url url)) + (setq url (url:parse-url new-location))))) (let* ((doc (make-instance 'r2::document :processes-hooks nil :location (r2::parse-url* url) From dlichteblau at common-lisp.net Sun Jan 7 19:33:02 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 7 Jan 2007 14:33:02 -0500 (EST) Subject: [closure-cvs] CVS closure/src Message-ID: <20070107193302.14EDF1704F@common-lisp.net> Update of /project/closure/cvsroot/closure/src In directory clnet:/tmp/cvs-serv18168/src Modified Files: defpack.lisp Log Message: Moved AIMAGE drawing routines into McCLIM. --- /project/closure/cvsroot/closure/src/defpack.lisp 2006/12/31 11:48:18 1.8 +++ /project/closure/cvsroot/closure/src/defpack.lisp 2007/01/07 19:33:02 1.9 @@ -95,8 +95,7 @@ (defpackage :ws/x11 (:use :glisp :runes :cl) - (:export - #:aimage->ximage)) + (:export)) (defpackage :gif (:use :glisp :runes :cl) From dlichteblau at common-lisp.net Sun Jan 7 19:33:02 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 7 Jan 2007 14:33:02 -0500 (EST) Subject: [closure-cvs] CVS closure/src/glisp Message-ID: <20070107193302.489B21704F@common-lisp.net> Update of /project/closure/cvsroot/closure/src/glisp In directory clnet:/tmp/cvs-serv18168/src/glisp Modified Files: util.lisp Log Message: Moved AIMAGE drawing routines into McCLIM. --- /project/closure/cvsroot/closure/src/glisp/util.lisp 2007/01/02 13:12:58 1.8 +++ /project/closure/cvsroot/closure/src/glisp/util.lisp 2007/01/07 19:33:02 1.9 @@ -325,7 +325,8 @@ ;;;; Homebrew stream classes ;;;; -;; I am really tired of standard Common Lisp streams and thier incompatible implementations. +;; I am really tired of standard Common Lisp streams and thier incompatible +implementations. ;; A gstream is an objects with obeys to the following protocol: From dlichteblau at common-lisp.net Sun Jan 7 19:33:02 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 7 Jan 2007 14:33:02 -0500 (EST) Subject: [closure-cvs] CVS closure/src/gui Message-ID: <20070107193302.8014B17050@common-lisp.net> Update of /project/closure/cvsroot/closure/src/gui In directory clnet:/tmp/cvs-serv18168/src/gui Modified Files: dce-and-pce.lisp gui.lisp Log Message: Moved AIMAGE drawing routines into McCLIM. --- /project/closure/cvsroot/closure/src/gui/dce-and-pce.lisp 2006/12/31 15:42:40 1.4 +++ /project/closure/cvsroot/closure/src/gui/dce-and-pce.lisp 2007/01/07 19:33:02 1.5 @@ -116,13 +116,13 @@ aimage width height - pixmap + design refcount) -(defun make-pixmap-from-aimage (drawable aimage width height) +(defun make-design-from-aimage (medium aimage width height) (dolist (k *pixmap-cache* - (let ((res (really-make-pixmap-from-aimage - drawable aimage width height))) + (let ((res (really-make-design-from-aimage + medium aimage width height))) (when *debug-pixmap-cache-p* (format T "~&;; ++ [init] ~A ~Dx~D " (getf (imagelib:aimage-plist aimage) :url) @@ -131,7 +131,7 @@ (push (make-pce :aimage aimage :width width :height height - :pixmap res + :design res :refcount 1) *pixmap-cache*) res)) @@ -144,21 +144,22 @@ width height)) (incf (pce-refcount k)) - (return (pce-pixmap k))))) + (return (pce-design k))))) -(defun really-make-pixmap-from-aimage (drawable aimage width height) - (multiple-value-list - (gui::aimage->pixmap+mask/raw drawable - (imagelib:scale-aimage aimage width height)))) +(defun really-make-design-from-aimage (medium aimage width height) + (climi::make-rgb-image-design medium + (imagelib::aimage-rgb-image + (imagelib:scale-aimage aimage width height)))) (defun reset-caches () (setf *dcache* nil *pixmap-cache* nil)) -(defun ws/x11::aimage->pixmap+mask (drawable aimage) - (make-pixmap-from-aimage drawable aimage - (imagelib:aimage-width aimage) - (imagelib:aimage-height aimage))) +;; apparently unused --dfl +;;;(defun ws/x11::aimage->pixmap+mask (drawable aimage) +;;; (make-design-from-aimage drawable aimage +;;; (imagelib:aimage-width aimage) +;;; (imagelib:aimage-height aimage))) (defclass r2::ro/img () ((url :initarg :url) @@ -166,8 +167,7 @@ (aim :initform nil) (width :initform nil) (height :initform nil) - (pixmap :initform nil) - (mask :initform nil))) + (design :initform nil))) (defmethod print-object ((self r2::ro/img) sink) (format sink "#<~S url=~S>" (type-of self) @@ -176,15 +176,14 @@ :unbound))) (defmethod deconstruct-robj ((self r2::ro/img)) - (with-slots ((aim-orig aim-orig) (pixmap pixmap) (mask mask)) self - (when pixmap - (deref-aimage-pixmap aim-orig (list pixmap mask)) - (setf pixmap nil - mask nil)))) + (with-slots ((aim-orig aim-orig) (design design)) self + (when design + (deref-aimage-design aim-orig design) + (setf design nil)))) -(defun deref-aimage-pixmap (aimage pixmap) +(defun deref-aimage-design (aimage design) (declare (ignore aimage)) - (let ((pce (find pixmap *pixmap-cache* :key #'pce-pixmap :test #'equal))) + (let ((pce (find design *design-cache* :key #'pce-design :test #'equal))) (assert (not (null pce))) (assert (> (pce-refcount pce) 0)) (when *debug-pixmap-cache-p* @@ -198,19 +197,13 @@ (let ((n 0)) (setf *pixmap-cache* (mapcan (lambda (pce) - (cond ((eql (pce-refcount pce) 0) - (and (car (pce-pixmap pce)) - (incf n (* (xlib:drawable-width (car (pce-pixmap pce))) - (xlib:drawable-height (car (pce-pixmap pce))))) - (xlib:free-pixmap (car (pce-pixmap pce)))) - (and (cadr (pce-pixmap pce)) - (incf n (* (xlib:drawable-width (cadr (pce-pixmap pce))) - (xlib:drawable-height (cadr (pce-pixmap pce))))) - (xlib:free-pixmap (cadr (pce-pixmap pce)))) - - nil) - (t - (list pce)))) + (cond + ((and (eql (pce-refcount pce) 0) (pce-design pce)) + (incf n (* (pce-width pce) (pce-height pce))) + (climi::free-image-design (pce-design pce)) + nil) + (t + (list pce)))) *pixmap-cache*)) n)) @@ -226,7 +219,7 @@ (values width height 0))) (defmethod r2::ro/resize ((self r2::ro/img) new-width new-height) - (with-slots (width height aim aim-orig pixmap mask) self + (with-slots (width height aim aim-orig design) self (cond ((and new-width new-height) (setf width (round new-width) height (round new-height)) ) @@ -247,36 +240,34 @@ (unless (and (eql new-width width) (eql new-height height)) (setf width new-width height new-height - pixmap nil mask nil + design nil aim nil #+(OR) (if aim (imagelib:scale-aimage aim-orig new-width new-height) nil) ))))) )) -(defun ensure-ro/img-pixmap (drawable self) - (with-slots (aim-orig width height pixmap mask) self - (when aim-orig - (unless pixmap - (let ((r (make-pixmap-from-aimage drawable aim-orig width height))) - (setf pixmap (car r) - mask (cadr r))))))) - -(defmethod r2::x11-draw-robj (drawable gcontext (self r2::ro/img) box x y) - (declare (ignore box)) - (setq x (round x)) - (setq y (round y)) - (with-slots ((aim-orig aim-orig) (width width) (height height) - (pixmap pixmap) - (mask mask)) - self - (ensure-ro/img-pixmap drawable self) - (when aim-orig - (cond ((not (null mask)) - (xlib:with-gcontext (gcontext :clip-mask mask - :clip-x x - :clip-y (- y height)) - (xlib:copy-area pixmap gcontext 0 0 width height - drawable x (- y height))) ) - (t - (xlib:copy-area pixmap gcontext 0 0 width height - drawable x (- y height) )))))) +;; apparently unused --dfl +;;;(defun ensure-ro/img-pixmap (drawable self) +;;; (with-slots (aim-orig width height design mask) self +;;; (when (and aim-orig (not design)) +;;; (setf design (make-design-from-aimage drawable aim-orig width height))))) + +;; apparently unused --dfl +;;;(defmethod r2::x11-draw-robj (drawable gcontext (self r2::ro/img) box x y) +;;; (declare (ignore box)) +;;; (setq x (round x)) +;;; (setq y (round y)) +;;; (with-slots ((aim-orig aim-orig) (width width) (height height) +;;; (design design)) +;;; self +;;; (ensure-ro/img-pixmap drawable self) +;;; (when aim-orig +;;; (cond ((not (null mask)) +;;; (xlib:with-gcontext (gcontext :clip-mask mask +;;; :clip-x x +;;; :clip-y (- y height)) +;;; (xlib:copy-area pixmap gcontext 0 0 width height +;;; drawable x (- y height))) ) +;;; (t +;;; (xlib:copy-area pixmap gcontext 0 0 width height +;;; drawable x (- y height) )))))) ;;; ---------------------------------------------------------------------------------------------------- --- /project/closure/cvsroot/closure/src/gui/gui.lisp 2006/12/30 15:08:09 1.8 +++ /project/closure/cvsroot/closure/src/gui/gui.lisp 2007/01/07 19:33:02 1.9 @@ -403,29 +403,6 @@ (defvar cl-user::*html-dtd* nil) -(defun aimage->pixmap+mask/raw (drawable aim) - (let* ((width (r2::aimage-width aim)) - (height (r2::aimage-height aim)) - (depth (xlib:drawable-depth drawable)) - (im (ws/x11::aimage->ximage drawable aim))) - (setf width (max width 1)) - (setf height (max height 1)) - (values - (let* ((pixmap (xlib:create-pixmap :drawable drawable - :width width - :height height - :depth depth)) - (gc (xlib:create-gcontext :drawable pixmap))) - (unless (or (>= width 2048) (>= height 2048)) ;### CLX bug - (xlib:put-image pixmap gc im - :src-x 0 :src-y 0 - :x 0 :y 0 - :width width :height height)) - (xlib:free-gcontext gc) - pixmap) - (when (imagelib:aimage-alpha-p aim) - (ws/x11::make-mask-from-aimage drawable aim))))) - (defun init-closure () ;; Init general closure stuff #|| From dlichteblau at common-lisp.net Sun Jan 7 19:33:02 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 7 Jan 2007 14:33:02 -0500 (EST) Subject: [closure-cvs] CVS closure/src/html Message-ID: <20070107193302.B2BB91704F@common-lisp.net> Update of /project/closure/cvsroot/closure/src/html In directory clnet:/tmp/cvs-serv18168/src/html Modified Files: html-style.lisp Log Message: Moved AIMAGE drawing routines into McCLIM. --- /project/closure/cvsroot/closure/src/html/html-style.lisp 2007/01/02 14:00:54 1.11 +++ /project/closure/cvsroot/closure/src/html/html-style.lisp 2007/01/07 19:33:02 1.12 @@ -1128,64 +1128,66 @@ (t (values 20 20 0))))) -(defmethod update-lazy-object (document (self ro/image)) - (with-slots (url fixed-size-p) self - (let ((aim (document-fetch-image document self url))) - (with-slots (iwidth iheight (self.aimage aimage) awidth aheight) self - (setf iwidth (aimage-width aim) - iheight (aimage-height aim) - self.aimage aim) - (unless awidth (setf awidth (aimage-width aim))) - (unless aheight (setf aheight (aimage-height aim))) - )) - (cond (fixed-size-p - ;; **hack** - (with-slots (aimage awidth aheight) self - (let ((drawable (xlib:screen-root (xlib:display-default-screen clue-gui2::*dpy*)))) - (with-slots (pixmap mask) self - (unless pixmap - (let ((q (clue-gui2::make-pixmap-from-aimage drawable aimage awidth aheight))) - (setf pixmap (car q) - mask (cadr q))))))) - ;; return - nil) - (t - ;; return - t)))) - -(defmethod x11-draw-robj (drawable gcontext (self ro/image) box x y) - (setf x (floor x)) - (setf y (floor y)) - (with-slots (alt awidth aheight aimage url) self - (cond (aimage - (unless awidth (setf awidth (aimage-width aimage))) - (unless aheight (setf aheight (aimage-height aimage))) - (with-slots (pixmap mask) self - (unless pixmap - (warn "Rendering pixmap while redisplay (~S)" - url) - (let ((q (clue-gui2::make-pixmap-from-aimage drawable aimage awidth aheight))) - (setf pixmap (car q) - mask (cadr q)))) - (cond ((not (null mask)) - (xlib:with-gcontext (gcontext :clip-mask mask - :clip-x x - :clip-y (- y aheight)) - (xlib:copy-area pixmap gcontext 0 0 awidth aheight - drawable x (- y aheight))) ) - (t - (xlib:copy-area pixmap gcontext 0 0 awidth aheight - drawable x (- y aheight) ))))) - - (t - (multiple-value-bind (w h) (ro/size self) - (setf w (floor w)) - (setf h (floor h)) - (xlib:with-gcontext (gcontext - :foreground (ws/x11::x11-find-color drawable :black) - ) - (xlib:draw-glyphs drawable gcontext x y (rod-string alt)) - (xlib:draw-rectangle drawable gcontext x (- y h) w h)))) ))) +;; apparently unused --dfl +;;;(defmethod update-lazy-object (document (self ro/image)) +;;; (with-slots (url fixed-size-p) self +;;; (let ((aim (document-fetch-image document self url))) +;;; (with-slots (iwidth iheight (self.aimage aimage) awidth aheight) self +;;; (setf iwidth (aimage-width aim) +;;; iheight (aimage-height aim) +;;; self.aimage aim) +;;; (unless awidth (setf awidth (aimage-width aim))) +;;; (unless aheight (setf aheight (aimage-height aim))) +;;; )) +;;; (cond (fixed-size-p +;;; ;; **hack** +;;; (with-slots (aimage awidth aheight) self +;;; (let ((drawable (xlib:screen-root (xlib:display-default-screen clue-gui2::*dpy*)))) +;;; (with-slots (pixmap mask) self +;;; (unless pixmap +;;; (let ((q (clue-gui2::make-design-from-aimage drawable aimage awidth aheight))) +;;; (setf pixmap (car q) +;;; mask (cadr q))))))) +;;; ;; return +;;; nil) +;;; (t +;;; ;; return +;;; t)))) + +;; apparently unused --dfl +;;;(defmethod x11-draw-robj (drawable gcontext (self ro/image) box x y) +;;; (setf x (floor x)) +;;; (setf y (floor y)) +;;; (with-slots (alt awidth aheight aimage url) self +;;; (cond (aimage +;;; (unless awidth (setf awidth (aimage-width aimage))) +;;; (unless aheight (setf aheight (aimage-height aimage))) +;;; (with-slots (pixmap mask) self +;;; (unless pixmap +;;; (warn "Rendering pixmap while redisplay (~S)" +;;; url) +;;; (let ((q (clue-gui2::make-design-from-aimage drawable aimage awidth aheight))) +;;; (setf pixmap (car q) +;;; mask (cadr q)))) +;;; (cond ((not (null mask)) +;;; (xlib:with-gcontext (gcontext :clip-mask mask +;;; :clip-x x +;;; :clip-y (- y aheight)) +;;; (xlib:copy-area pixmap gcontext 0 0 awidth aheight +;;; drawable x (- y aheight))) ) +;;; (t +;;; (xlib:copy-area pixmap gcontext 0 0 awidth aheight +;;; drawable x (- y aheight) ))))) +;;; +;;; (t +;;; (multiple-value-bind (w h) (ro/size self) +;;; (setf w (floor w)) +;;; (setf h (floor h)) +;;; (xlib:with-gcontext (gcontext +;;; :foreground (ws/x11::x11-find-color drawable :black) +;;; ) +;;; (xlib:draw-glyphs drawable gcontext x y (rod-string alt)) +;;; (xlib:draw-rectangle drawable gcontext x (- y h) w h)))) ))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From dlichteblau at common-lisp.net Sun Jan 7 19:33:02 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 7 Jan 2007 14:33:02 -0500 (EST) Subject: [closure-cvs] CVS closure/src/imagelib Message-ID: <20070107193302.EF12017050@common-lisp.net> Update of /project/closure/cvsroot/closure/src/imagelib In directory clnet:/tmp/cvs-serv18168/src/imagelib Modified Files: basic.lisp gif.lisp Log Message: Moved AIMAGE drawing routines into McCLIM. --- /project/closure/cvsroot/closure/src/imagelib/basic.lisp 2007/01/03 15:39:29 1.4 +++ /project/closure/cvsroot/closure/src/imagelib/basic.lisp 2007/01/07 19:33:02 1.5 @@ -1,4 +1,4 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: RENDERER; -*- +;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*- ;;; --------------------------------------------------------------------------- ;;; Title: General image routines ;;; Created: 1998-11-11 @@ -38,18 +38,28 @@ (in-package :imagelib) -(defstruct (aimage - (:constructor make-aimage/low) - (:copier nil) - (:print-function print-aimage)) - (width 0 :type fixnum) - (height 0 :type fixnum) - (data nil :type (or null (simple-array (unsigned-byte 32) (* *)))) - alpha-p - plist) +;;; AIMAGE has been moved into McCLIM under the name RGB-IMAGE, but +;;; without a plist and with different slot accessors. Here's a wrapper +;;; class for now: +(defclass aimage () + ((rgb-image :initarg :rgb-image :accessor aimage-rgb-image) + (plist :initarg :plist :accessor aimage-plist))) + +(defun aimage-width (ai) (climi::image-width (aimage-rgb-image ai))) +(defun aimage-height (ai) (climi::image-height (aimage-rgb-image ai))) +(defun aimage-data (ai) (climi::image-data (aimage-rgb-image ai))) +(defun aimage-alpha-p (ai) (climi::image-alpha-p (aimage-rgb-image ai))) + +(defun make-aimage/low (&key width height data alphap plist) + (make-instance 'aimage + :rgb-image (make-instance 'climi::rgb-image + :width width + :height height + :data data + :alphap alphap) + :plist plist)) -(defun print-aimage (self sink depth) - (declare (ignore depth)) +(defmethod print-object ((self aimage) sink) (format sink "<~S ~D x ~D from ~S>" 'aimage (aimage-width self) (aimage-height self) (getf (aimage-plist self) :url))) @@ -59,7 +69,7 @@ :height height :data (make-array (list height width) :element-type '(unsigned-byte 32)) - :alpha-p alpha-p)) + :alphap alpha-p)) (defun scale-aimage (source new-width new-height) (when (or (zerop new-width) (zerop new-height)) --- /project/closure/cvsroot/closure/src/imagelib/gif.lisp 2007/01/03 16:41:15 1.2 +++ /project/closure/cvsroot/closure/src/imagelib/gif.lisp 2007/01/07 19:33:02 1.3 @@ -57,7 +57,7 @@ (skippy:color-rgb (skippy:color-table-entry gif-color-table color-index)))) (setf (aref aimage-data y x) - (dpb r (byte 8 0) +9D (dpb r (byte 8 0) (dpb g (byte 8 8) (dpb b (byte 8 16) (dpb (or a 0) (byte 8 24) 0)))))))) From dlichteblau at common-lisp.net Sun Jan 7 19:33:03 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 7 Jan 2007 14:33:03 -0500 (EST) Subject: [closure-cvs] CVS closure/src/renderer Message-ID: <20070107193303.4B4FB1705D@common-lisp.net> Update of /project/closure/cvsroot/closure/src/renderer In directory clnet:/tmp/cvs-serv18168/src/renderer Modified Files: clim-device.lisp images.lisp x11.lisp Log Message: Moved AIMAGE drawing routines into McCLIM. --- /project/closure/cvsroot/closure/src/renderer/clim-device.lisp 2007/01/02 12:08:44 1.14 +++ /project/closure/cvsroot/closure/src/renderer/clim-device.lisp 2007/01/07 19:33:03 1.15 @@ -190,8 +190,9 @@ ;;; (values (r2::background-%pixmap bg) ;;; (r2::background-%mask bg))))) -(defmethod update-lazy-object (document (self null)) - nil) +;; apparently unused --dfl +;;;(defmethod update-lazy-object (document (self null)) +;;; nil) (defun map-region-rectangles (fun region) (clim:map-over-region-set-regions @@ -221,27 +222,29 @@ (+ (second q) (fourth q)))))) res)) -(defun background-pixmap+mask (document drawable bg) - (cond ((r2::background-%pixmap bg) - ;; already there - (values (r2::background-%pixmap bg) - (r2::background-%mask bg))) - (t - (let ((aimage #+NIL(r2::document-fetch-image document nil (r2::background-image bg)) - (r2::url->aimage document (r2::background-image bg) nil) - )) - ;; arg, jetzt haben wir wieder broken images - (cond ((eql nil aimage) - (values :none)) - (t - (cond ((eq aimage :error) - (setf (r2::background-%pixmap bg) :none) ) - (t - (let ((pm (ws/x11::aimage->pixmap+mask drawable aimage))) - (setf (r2::background-%pixmap bg) (car pm) - (r2::background-%mask bg) (cadr pm))))) - (values (r2::background-%pixmap bg) - (r2::background-%mask bg)))))) )) +;; apparently unused --dfl + +;;;(defun background-pixmap+mask (document drawable bg) +;;; (cond ((r2::background-%pixmap bg) +;;; ;; already there +;;; (values (r2::background-%pixmap bg) +;;; (r2::background-%mask bg))) +;;; (t +;;; (let ((aimage #+NIL(r2::document-fetch-image document nil (r2::background-image bg)) +;;; (r2::url->aimage document (r2::background-image bg) nil) +;;; )) +;;; ;; arg, jetzt haben wir wieder broken images +;;; (cond ((eql nil aimage) +;;; (values :none)) +;;; (t +;;; (cond ((eq aimage :error) +;;; (setf (r2::background-%pixmap bg) :none) ) +;;; (t +;;; (let ((pm (ws/x11::aimage->pixmap+mask drawable aimage))) +;;; (setf (r2::background-%pixmap bg) (car pm) +;;; (r2::background-%mask bg) (cadr pm))))) +;;; (values (r2::background-%pixmap bg) +;;; (r2::background-%mask bg)))))) )) (defun ws/x11::x11-put-pixmap-tiled (drawable ggc pixmap mask x y w h &optional (xo 0) (yo 0)) (cond ((null mask) ;; xxx @@ -357,43 +360,45 @@ ;; and xlib:with-gcontext also is broken! (setf (xlib:gcontext-clip-mask ggc) old-clip-mask)))))) -(defun x11-draw-background (document medium bg x y width height - &optional (bix x) (biy y) (biwidth width) (biheight height)) - (when bg - ;; #+NIL - ;; (unless (eql (background-color bg) :transparent) - ;; (ws/x11::fill-rectangle* drawable gcontext - ;; (round x) (round y) - ;; (max 0 (round width)) - ;; (max 0 (round height)) - ;; (background-color bg)) ) - (unless (eql (r2::background-image bg) :none) - (multiple-value-bind (pixmap mask) - (background-pixmap+mask document (sheet-direct-mirror (medium-sheet medium)) bg) - #+emarsden2005-07-15 - (print (list 'x11-draw-background pixmap mask)) - (unless (eql pixmap :none) - (let* ((iw (xlib:drawable-width pixmap)) - (ih (xlib:drawable-height pixmap)) - (w (ecase (r2::background-repeat bg) - ((:repeat :repeat-x) width) - ((:no-repeat :repeat-y) iw))) - (h (ecase (r2::background-repeat bg) - ((:repeat :repeat-y) height) - ((:no-repeat :repeat-x) ih))) ) - (let ((hp (car (r2::background-position bg))) - (vp (cdr (r2::background-position bg)))) - (let ((xo (+ bix (resolve-background-position hp iw biwidth))) - (yo (+ biy (resolve-background-position vp ih biheight)))) - (medium-draw-pm3-tiled* medium pixmap mask - (round (ecase (r2::background-repeat bg) - ((:repeat :repeat-x) x) - ((:no-repeat :repeat-y) (+ xo)))) - (round (ecase (r2::background-repeat bg) - ((:repeat :repeat-y) y) - ((:no-repeat :repeat-x) (+ yo)))) - (round w) (round h) - (round (+ xo)) (round (+ yo)))))) ))) )) +;; apparently unused --dfl + +;;;(defun x11-draw-background (document medium bg x y width height +;;; &optional (bix x) (biy y) (biwidth width) (biheight height)) +;;; (when bg +;;; ;; #+NIL +;;; ;; (unless (eql (background-color bg) :transparent) +;;; ;; (ws/x11::fill-rectangle* drawable gcontext +;;; ;; (round x) (round y) +;;; ;; (max 0 (round width)) +;;; ;; (max 0 (round height)) +;;; ;; (background-color bg)) ) +;;; (unless (eql (r2::background-image bg) :none) +;;; (multiple-value-bind (pixmap mask) +;;; (background-pixmap+mask document (sheet-direct-mirror (medium-sheet medium)) bg) +;;; #+emarsden2005-07-15 +;;; (print (list 'x11-draw-background pixmap mask)) +;;; (unless (eql pixmap :none) +;;; (let* ((iw (xlib:drawable-width pixmap)) +;;; (ih (xlib:drawable-height pixmap)) +;;; (w (ecase (r2::background-repeat bg) +;;; ((:repeat :repeat-x) width) +;;; ((:no-repeat :repeat-y) iw))) +;;; (h (ecase (r2::background-repeat bg) +;;; ((:repeat :repeat-y) height) +;;; ((:no-repeat :repeat-x) ih))) ) +;;; (let ((hp (car (r2::background-position bg))) +;;; (vp (cdr (r2::background-position bg)))) +;;; (let ((xo (+ bix (resolve-background-position hp iw biwidth))) +;;; (yo (+ biy (resolve-background-position vp ih biheight)))) +;;; (medium-draw-pm3-tiled* medium pixmap mask +;;; (round (ecase (r2::background-repeat bg) +;;; ((:repeat :repeat-x) x) +;;; ((:no-repeat :repeat-y) (+ xo)))) +;;; (round (ecase (r2::background-repeat bg) +;;; ((:repeat :repeat-y) y) +;;; ((:no-repeat :repeat-x) (+ yo)))) +;;; (round w) (round h) +;;; (round (+ xo)) (round (+ yo)))))) ))) )) ;;;; -------------------------------------------------------------------------------- @@ -406,8 +411,7 @@ (actual-height :initarg :actual-height :initform nil :documentation "The actual (scaled) height of this image.") - (pixmap :initform nil) - (mask :initform nil))) + (design :initform nil))) (defmethod gui::deconstruct-robj ((self ro/img)) ;; no deconstructor for now ... @@ -459,60 +463,41 @@ (defmethod medium-draw-ro* ((medium clim:medium) (self ro/img) x y) - (progn ;; ignore-errors ;xxx - (progn - (assert (realp x)) - (assert (realp y)) - (with-slots (aim pixmap mask actual-width actual-height) self - (when aim ;only draw something, if the image is already there. - ;; xxx - (let ((da (sheet-direct-mirror (medium-sheet medium)))) - (when (and aim actual-width actual-height) ;xxx - (unless pixmap - (let ((r (clue-gui2::make-pixmap-from-aimage da aim - (max 1 (round actual-width)) - (max 1 (round actual-height))))) - (setf pixmap (car r) - mask (cadr r))))) - (when aim - (multiple-value-bind (x y) (transform-position - (sheet-device-transformation (medium-sheet medium)) - x y) - (setf x (round x)) - (setf y (round y)) - (let ((gcontext (xlib:create-gcontext :drawable da))) - (cond ((not (null mask)) - (xlib:with-gcontext (gcontext - :clip-mask mask - :clip-x x - :clip-y (- y actual-height)) - (xlib:copy-area pixmap gcontext 0 0 actual-width actual-height - da x (- y actual-height))) ) - (t - (xlib:copy-area pixmap gcontext 0 0 actual-width actual-height - da x (- y actual-height) )))))))))))) - -#+NIL -(climi::def-grecording draw-pm3-tiled (() pixmap mask x1 y1 w h x0 y0) - (values x1 y1 (+ x1 w) (+ y1 h))) - -(defmethod medium-draw-pm3-tiled* (medium pixmap mask x1 y1 w h x0 y0) - (let* ((da (sheet-direct-mirror (medium-sheet medium))) - #+NIL - (pixmap+mask (clue-gui2::make-pixmap-from-aimage da aim - (r2::aimage-width aim) - (r2::aimage-height aim))) - #+NIL - (pixmap (first pixmap+mask)) - #+NIL - (mask (second pixmap+mask))) - (multiple-value-bind (x1 y1) (transform-position (sheet-device-transformation (medium-sheet medium)) - x1 y1) - (setf x1 (round x1)) - (setf y1 (round y1)) - ;;; - (let ((gcontext (xlib:create-gcontext :drawable da))) - (ws/x11::x11-put-pixmap-tiled da gcontext pixmap mask x1 y1 w h x0 y0) )))) + (assert (realp x)) + (assert (realp y)) + (with-slots (aim design actual-width actual-height) self + (when aim ;only draw something, if the image is already there. + ;; xxx + (when (and actual-width actual-height (not design)) ;xxx + (setf design + (clue-gui2::make-design-from-aimage medium + aim + (max 1 (round actual-width)) + (max 1 (round actual-height))))) + (climi::medium-draw-image-design* medium design x y)))) + +;; apparently unused --dfl +;;;#+NIL +;;;(climi::def-grecording draw-pm3-tiled (() pixmap mask x1 y1 w h x0 y0) +;;; (values x1 y1 (+ x1 w) (+ y1 h))) +;;; +;;;(defmethod medium-draw-pm3-tiled* (medium pixmap mask x1 y1 w h x0 y0) +;;; (let* ((da (sheet-direct-mirror (medium-sheet medium))) +;;; #+NIL +;;; (pixmap+mask (clue-gui2::make-pixmap-from-aimage da aim +;;; (r2::aimage-width aim) +;;; (r2::aimage-height aim))) +;;; #+NIL +;;; (pixmap (first pixmap+mask)) +;;; #+NIL +;;; (mask (second pixmap+mask))) +;;; (multiple-value-bind (x1 y1) (transform-position (sheet-device-transformation (medium-sheet medium)) +;;; x1 y1) +;;; (setf x1 (round x1)) +;;; (setf y1 (round y1)) +;;; ;;; +;;; (let ((gcontext (xlib:create-gcontext :drawable da))) +;;; (ws/x11::x11-put-pixmap-tiled da gcontext pixmap mask x1 y1 w h x0 y0) )))) #+NIL --- /project/closure/cvsroot/closure/src/renderer/images.lisp 2007/01/03 15:39:29 1.4 +++ /project/closure/cvsroot/closure/src/renderer/images.lisp 2007/01/07 19:33:03 1.5 @@ -55,7 +55,7 @@ (unless (url:url-p url) (setq url (url:parse-url url))) (multiple-value-bind (aimage condition) - (ignore-errors + (progn ;ignore-errors (netlib:with-open-document ((input mime-type) url nil ;reload-p t ;binary-p --- /project/closure/cvsroot/closure/src/renderer/x11.lisp 2006/12/30 15:13:55 1.10 +++ /project/closure/cvsroot/closure/src/renderer/x11.lisp 2007/01/07 19:33:03 1.11 @@ -480,31 +480,6 @@ ;;;; ========================================================================================== -(defun make-ximage-for-aimage (aimage depth translator) - #+EXCL (declare (:explain :calls)) - (let* ((width (imagelib:aimage-width aimage)) - (height (imagelib:aimage-height aimage)) - (idata (imagelib:aimage-data aimage)) - ;; FIXME: this (and the :BITS-PER-PIXEL, below) is a hack on - ;; top of a hack. At some point in the past, XFree86 and/or - ;; X.org decided that they would no longer support pixmaps - ;; with 24 bpp, which seems to be what most AIMAGEs want to - ;; be. For now, force everything to a 32-bit pixmap. - (xdata (make-array (list height width) :element-type '(unsigned-byte 32))) - (ximage (xlib:create-image :width width - :height height - :depth depth - :bits-per-pixel 32 - :data xdata))) - (declare (type (simple-array (unsigned-byte 32) (* *)) idata) - #+NIL(type (simple-array (unsigned-byte 8) (* *)) xdata) - ) - (loop for x fixnum from 0 below width do - (loop for y fixnum from 0 below height do - (setf (aref xdata y x) - (funcall translator x y (ldb (byte 24 0) (aref idata y x)))))) - ximage)) - (defun ximage-translator** (window) (ximage-translator* (pixel-translator-code (xlib:window-colormap window)) (xlib:drawable-depth window))) @@ -570,40 +545,6 @@ (setf (getf (colormap-plist (xlib:window-colormap window)) 'ximage-translator) (compile nil (ximage-translator** window))))) -#+NIL ;; not yet trusted -(defun aimage->ximage (drawable aimage) - (funcall (ximage-translator drawable) aimage)) - -(defun aimage->ximage (drawable aimage) - (make-ximage-for-aimage aimage - (xlib:drawable-depth drawable) - (pixel-translator (xlib:window-colormap drawable)))) - -(defun make-mask-from-aimage (drawable aim) - (let* ((width (imagelib:aimage-width aim)) - (height (imagelib:aimage-height aim)) - (bitmap (xlib:create-pixmap :drawable drawable - :width width - :height height - :depth 1)) - (gc (xlib:create-gcontext :drawable bitmap :foreground 1 :background 0)) - (idata (imagelib:aimage-data aim)) - (xdata (make-array (list height width) :element-type '(unsigned-byte 1))) - (im (xlib:create-image :width width - :height height - :depth 1 - :data xdata)) ) - (dotimes (y width) - (dotimes (x height) - (if (> (aref idata x y) #x80000000) - (setf (aref xdata x y) 0) - (setf (aref xdata x y) 1)))) - (unless (or (>= width 2048) (>= height 2048)) ;### CLX breaks here - (xlib:put-image bitmap gc im :src-x 0 :src-y 0 :x 0 :y 0 :width width :height height - :bitmap-p nil)) - (xlib:free-gcontext gc) - bitmap)) - ;;;; -------------------------------------------------------------------------- ;;;; colours ;;;; From dlichteblau at common-lisp.net Sun Jan 7 19:35:08 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 7 Jan 2007 14:35:08 -0500 (EST) Subject: [closure-cvs] CVS closure/src/glisp Message-ID: <20070107193508.3DCFC56010@common-lisp.net> Update of /project/closure/cvsroot/closure/src/glisp In directory clnet:/tmp/cvs-serv18578 Modified Files: util.lisp Log Message: revert accidental change --- /project/closure/cvsroot/closure/src/glisp/util.lisp 2007/01/07 19:33:02 1.9 +++ /project/closure/cvsroot/closure/src/glisp/util.lisp 2007/01/07 19:35:08 1.10 @@ -325,8 +325,7 @@ ;;;; Homebrew stream classes ;;;; -;; I am really tired of standard Common Lisp streams and thier incompatible -implementations. +;; I am really tired of standard Common Lisp streams and thier incompatible implementations. ;; A gstream is an objects with obeys to the following protocol: From dlichteblau at common-lisp.net Sun Jan 7 19:52:11 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 7 Jan 2007 14:52:11 -0500 (EST) Subject: [closure-cvs] CVS closure/src/imagelib Message-ID: <20070107195211.AE84260035@common-lisp.net> Update of /project/closure/cvsroot/closure/src/imagelib In directory clnet:/tmp/cvs-serv21323 Modified Files: gif.lisp Log Message: revert accidental change --- /project/closure/cvsroot/closure/src/imagelib/gif.lisp 2007/01/07 19:33:02 1.3 +++ /project/closure/cvsroot/closure/src/imagelib/gif.lisp 2007/01/07 19:52:11 1.4 @@ -57,7 +57,7 @@ (skippy:color-rgb (skippy:color-table-entry gif-color-table color-index)))) (setf (aref aimage-data y x) -9D (dpb r (byte 8 0) + (dpb r (byte 8 0) (dpb g (byte 8 8) (dpb b (byte 8 16) (dpb (or a 0) (byte 8 24) 0)))))))) From emarsden at common-lisp.net Sun Jan 7 20:23:59 2007 From: emarsden at common-lisp.net (emarsden) Date: Sun, 7 Jan 2007 15:23:59 -0500 (EST) Subject: [closure-cvs] CVS closure/src/imagelib Message-ID: <20070107202359.3663921044@common-lisp.net> Update of /project/closure/cvsroot/closure/src/imagelib In directory clnet:/tmp/cvs-serv26443 Modified Files: basic.lisp Log Message: Trivial bugfix. --- /project/closure/cvsroot/closure/src/imagelib/basic.lisp 2007/01/07 19:33:02 1.5 +++ /project/closure/cvsroot/closure/src/imagelib/basic.lisp 2007/01/07 20:23:59 1.6 @@ -304,7 +304,7 @@ (make-aimage/low :width (array-dimension arr 1) :height (array-dimension arr 0) :data arr - :alpha-p nil))) + :alphap nil))) (defun any->aimage-by-filter (filter-name input) From dlichteblau at common-lisp.net Sun Jan 21 15:25:27 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 21 Jan 2007 10:25:27 -0500 (EST) Subject: [closure-cvs] CVS closure/src/parse Message-ID: <20070121152527.E0D672F027@common-lisp.net> Update of /project/closure/cvsroot/closure/src/parse In directory clnet:/tmp/cvs-serv17861 Modified Files: sgml-parse.lisp Log Message: rune fix --- /project/closure/cvsroot/closure/src/parse/sgml-parse.lisp 2006/12/31 12:05:33 1.6 +++ /project/closure/cvsroot/closure/src/parse/sgml-parse.lisp 2007/01/21 15:25:27 1.7 @@ -961,9 +961,9 @@ (sgml::find-element dtd name nil nil))) (defun foofoo (r) - (cond ((integerp r) (map 'rod #'char-code (prin1-to-string r))) - ((symbolp r) (map 'rod #'char-code (princ-to-string r))) - ((stringp r) (map 'rod #'char-code r)) + (cond ((integerp r) (string-rod (prin1-to-string r))) + ((symbolp r) (string-rod (princ-to-string r))) + ((stringp r) (string-rod r)) (t (error "foofoo: Hmm ~S ?!" r)))) From thenriksen at common-lisp.net Sun Jan 7 17:29:47 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 07 Jan 2007 17:29:47 -0000 Subject: [closure-cvs] CVS closure/resources Message-ID: <20070107172947.A22AC2D01F@common-lisp.net> Update of /project/closure/cvsroot/closure/resources In directory clnet:/tmp/cvs-serv21553/resources Modified Files: resources.lisp Log Message: Make Closure work better with common-lisp-controller-like setups. --- /project/closure/cvsroot/closure/resources/resources.lisp 2005/03/13 18:00:55 1.3 +++ /project/closure/cvsroot/closure/resources/resources.lisp 2007/01/07 17:29:47 1.4 @@ -36,7 +36,7 @@ #+NIL (defparameter *resources-base-directory* *load-truename*) -(let ((load-truename *load-truename*)) +(let ((load-truename (load-time-value (or #.*compile-file-pathname* *load-pathname*)))) (setf (url:url-logical-host-translator "closure") (lambda (url) (let ((res (url:copy-url url)))