source: trunk/source/examples/webkit.lisp @ 13474

Last change on this file since 13474 was 11968, checked in by gb, 10 years ago

Try to ensure that window/view creation and initialization happens on the
main thread.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 3.3 KB
Line 
1
2;;;-*-Mode: LISP; Package: CCL -*-
3
4(in-package "CCL")
5
6(eval-when (:compile-toplevel :load-toplevel :execute)
7  (require "COCOA"))
8
9(eval-when (:compile-toplevel :load-toplevel :execute)
10  (objc:load-framework "WebKit" :webkit))
11
12
13(defun pathname-to-file-url (pathname)
14  ;; NATIVE-TRANSLATED-NAMESTRING returns a simple string that can be
15  ;; passed to a filesystem function.  (It may be exactly the same as
16  ;; what NAMESTRING returns, or it may differ if special characters
17  ;; were escaped in NAMESTRING's result.)
18  (with-autorelease-pool
19    (#/retain
20     (#/fileURLWithPath: ns:ns-url (%make-nsstring
21                                    (native-translated-namestring pathname))))))
22
23(defun url-from-string (s)
24  (with-autorelease-pool
25    (#/retain (#/URLWithString: ns:ns-url (%make-nsstring (string s))))))
26                 
27
28(defun %browser-window (urlspec)
29  (gui::assume-cocoa-thread)
30  ;; Content rect for window, bounds rect for view.
31  (ns:with-ns-rect (r 100.0 100.0 800.0 600.0)
32    (with-autorelease-pool 
33      (let* ((url (if (typep urlspec 'pathname)
34                    (pathname-to-file-url urlspec)
35                    (url-from-string urlspec)))
36             ;; Create a window with titlebar, close & iconize buttons
37             (w (make-instance
38                 'ns:ns-window
39                 :with-content-rect r
40                 :style-mask (logior #$NSTitledWindowMask
41                                     #$NSClosableWindowMask
42                                     #$NSMiniaturizableWindowMask
43                                     #$NSResizableWindowMask)
44                 ;; Backing styles other than #$NSBackingStoreBuffered
45                 ;; don't work at all in Cocoa.
46                 :backing #$NSBackingStoreBuffered
47                 :defer t)))
48        (#/setTitle: w (#/absoluteString url))
49        ;; Create a web-view instance,
50        (let* ((v (make-instance
51                   'ns:web-view
52                   :with-frame r
53                   :frame-name #@"frame" ; could be documented a bit better ...
54                   :group-name #@"group"))) ; as could this
55          ;; Make the view be the window's content view.
56          (#/setContentView: w v)
57          ;; Start a URL request.  The request is processed
58          ;; asynchronously, but apparently needs to be initiated
59          ;; from the event-handling thread.
60          (let* ((webframe (#/mainFrame v))
61                 (request (#/requestWithURL: ns:ns-url-request url)))
62            ;; Failing to wait until the main thread has
63            ;; initiated the request seems to cause
64            ;; view-locking errors.  Maybe that's just
65            ;; an artifact of some other problem.
66            (#/loadRequest: webframe request)
67            ;; Make the window visible & activate it
68            ;; The view knows how to draw itself and respond
69            ;; to events.
70            (#/makeKeyAndOrderFront: w +null-ptr+))
71          v)))))
72
73(defun browser-window (urlspec)
74  (let* ((ip ccl::*initial-process*))
75    (if (eq ccl::*current-process* ip)
76      (%browser-window urlspec)
77      (let* ((s (make-semaphore))
78             (v nil))
79        (process-interrupt ip (lambda ()
80                                (setq v (%browser-window urlspec))
81                                (signal-semaphore s)))
82        (wait-on-semaphore s)
83        v))))
84
85       
86;;; (browser-window "http://openmcl.clozure.com")
Note: See TracBrowser for help on using the repository browser.