src/renderer/document.lisp

   1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: RENDERER; -*-
   2 ;;; --------------------------------------------------------------------------------------
   3 ;;;     Title: The Document Class
   4 ;;;   Created: 1999-05-07 01:56
   5 ;;;    Author: Gilbert Baumann <gilbert@base-engineering.com>
   6 ;;;   License: MIT style (see below)
   7 ;;; --------------------------------------------------------------------------------------
   8 ;;;  (c) copyright 1999 by Gilbert Baumann
   9
  10 ;;;  Permission is hereby granted, free of charge, to any person obtaining
  11 ;;;  a copy of this software and associated documentation files (the
  12 ;;;  "Software"), to deal in the Software without restriction, including
  13 ;;;  without limitation the rights to use, copy, modify, merge, publish,
  14 ;;;  distribute, sublicense, and/or sell copies of the Software, and to
  15 ;;;  permit persons to whom the Software is furnished to do so, subject to
  16 ;;;  the following conditions:
  17 ;;;
  18 ;;;  The above copyright notice and this permission notice shall be
  19 ;;;  included in all copies or substantial portions of the Software.
  20 ;;;
  21 ;;;  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  22 ;;;  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  23 ;;;  MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  24 ;;;  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  25 ;;;  CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  26 ;;;  TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  27 ;;;  SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  28
  29 (in-package :RENDERER)
  30
  31 (defclass document ()
  32   ((pt           :initarg :pt           :initform nil :accessor document-pt)
  33    (links        :initarg :links        :initform nil :accessor document-links)
  34    (title        :initarg :title        :initform nil :accessor document-title)
  35    (display-list :initarg :display-list :initform nil :accessor document-display-list)
  36    (location     :initarg :location     :initform nil :accessor document-location
  37                  :documentation "Location of this document (an URL).")
  38    (http-header  :initarg :http-header  :initform nil :accessor document-http-header)
  39
  40    ;; list of all processes working for this document
  41    (processes      :initform nil :accessor document-processes)
  42    (processes/lock :initform (bordeaux-threads:make-lock "doc-proc-list Lock")
  43                    :accessor document-processes/lock) ;this needs a lock
  44    (processes/cv :initform (bordeaux-threads:make-condition-variable)
  45                  :accessor document-processes/cv)
  46    (processes-hooks
  47     ;; a list of hooks to call when ever the value of processes changes.
  48     :initform nil
  49     :accessor document-processes-hooks
  50     :initarg :processes-hooks)
  51
  52    (dead-p         :initform nil :accessor document-dead-p)
  53
  54    (source         :initform nil :accessor document-source)
  55
  56    ;;
  57    (images
  58     :initform nil
  59     :accessor document-images)
  60
  61    (anchors
  62     :initform nil
  63     :accessor document-anchors
  64     :documentation "A list anchors in this document.")
  65
  66    (selected-author-style
  67     :initform :default
  68     :initarg  :selected-author-style
  69     :accessor document-selected-author-style)
  70    ))
  71
  72 (defclass link ()
  73   ((title  :initarg :title  :accessor link-title)
  74    (rel    :initarg :rel    :accessor link-rel)
  75    (rev    :initarg :rev    :accessor link-rev)
  76    (type   :initarg :type   :accessor link-type)
  77    (media  :initarg :media  :accessor link-media)
  78    (target :initarg :target :accessor link-target)
  79    (href   :initarg :href   :accessor link-href)))
  80
  81 (defstruct anchor
  82   name                                  ;name of anchor (a string)
  83   x y)                                  ;coordinates of anchor
  84
  85 (defun document-base-url (document)
  86   (with-slots (location pt) document
  87     (or (closure-protocol:element-base-url closure-protocol:*document-language* pt)
  88         location)))
  89
  90 (defun run-process-on-behalf-of-document (document continuation &key (name "anonymous process"))
  91   ;; Runs a process on behalf of a document, `continuation' is the
  92   ;; function to be run within the new process.
  93   ;; Returns the new process created.
  94   (bordeaux-threads:with-recursive-lock-held ((document-processes/lock document))
  95     (let (new-process)
  96       (setf new-process
  97         (bordeaux-threads:make-thread
  98          ;; << child
  99          (lambda ()
 100            (catch 'quit-dce-process
 101              (unwind-protect
 102                  (funcall continuation)
 103                ;; remove myself from the list of processes
 104                (progn
 105                  (bordeaux-threads:with-recursive-lock-held ((document-processes/lock document))
 106                    (setf (document-processes document)
 107                          (delete new-process (document-processes document)))
 108                    (bordeaux-threads:condition-notify
 109                     (document-processes/cv document)))))))
 110          ;; >>
 111          :name name))
 112       ;; add new process to list of process
 113       (push new-process (document-processes document))
 114       new-process)))
 115
 116 ;; bordeaux-threads says that kill-thread might not unwind cleanly.
 117 ;; Let's use interrupt-thread then.
 118 (defun kill-dce-thread (thread)
 119   (bordeaux-threads:interrupt-thread
 120    thread
 121    (lambda () (throw 'quit-dce-process nil))))
 122
 123 (defun kill-all-document-processes (document)
 124   (setf (document-dead-p document) t)
 125   (bordeaux-threads:with-recursive-lock-held ((document-processes/lock document))
 126     (mapc #'kill-dce-thread (document-processes document)))
 127   (loop
 128     (bordeaux-threads:with-recursive-lock-held ((document-processes/lock document))
 129       (unless (document-processes document)
 130         (return))
 131       (bordeaux-threads:condition-wait (document-processes/cv document))))
 132   (values))
 133
 134 (defstruct image-entry
 135   url
 136   aimage
 137   objects)
 138
 139 (defun document-fetch-image (document object url)
 140   (let ((x (or (find (url:unparse-url url) (document-images document)
 141                      :test #'equalp
 142                      :key #'image-entry-url)
 143                (car (push (make-image-entry :url (url:unparse-url url)) (document-images document))))))
 144     (pushnew object (image-entry-objects x))
 145     (image-entry-aimage x)))
 146
 147 (defun document-add-anchor (document name x y)
 148   (push (make-anchor :name name :x x :y y)
 149         (document-anchors document)))
 150
 151 (defun document-style-sheet (doc &key (selected-style :default))
 152   "Compute the documents style. This could be either a <STYLE> element
 153   in the header or an external style sheet defined via <LINK>."
 154   ;; It isn't exactly specified, what one should do, when multiple
 155   ;; STYLE nodes are present.
 156   ;; We take the route to parse all styles present by either LINK or
 157   ;; STYLE and combine, as if they occured via @import.
 158   (let ((sheets nil)
 159         (pt (document-pt doc)))
 160     (dolist (link (document-links doc))
 161       (when (and (style-sheet-link-p link)
 162                  (style-link-does-apply-p link selected-style)
 163                  (link-href link))
 164         (let* ((media-type
 165                 (or (ignore-errors
 166                      (css::parse-media-type (link-media link)))
 167                     :all))
 168                (href (link-href link))
 169                (sheet (maybe-parse-style-sheet-from-url
 170                        href
 171                        :name "Document style via LINK"
 172                        :media-type media-type)))
 173           (when sheet
 174             (push sheet sheets)))))
 175     ;;
 176     (let ((style (closure-protocol:root-element-embedded-style
 177                   closure-protocol:*document-language*
 178                   pt)))
 179       (when style
 180         (multiple-value-bind (res condition)
 181             (ignore-errors
 182              (css:parse-style-sheet (cl-char-stream->gstream
 183                                      (make-string-input-stream
 184                                       style))
 185                                     nil
 186                                     :name "Document Style via STYLE"
 187                                     :base-url (document-base-url doc)))
 188           (cond ((null res)
 189                  (warn "Error while parsing embedded style sheet in ~S:~% ~A"
 190                        (r2::document-location doc)
 191                        condition))
 192                 (t
 193                  (push res sheets))))))
 194     (setf sheets (nreverse sheets))
 195     (let ((s (css:create-style-sheet *default-style-sheet*
 196                                      :name "Document style"
 197                                      :base-url (document-base-url doc))))
 198       (setf (css::style-sheet-imported-sheets s)
 199         sheets)
 200       s)))