/usr/share/common-lisp/source/mcclim/grafts.lisp is in cl-mcclim 0.9.6.dfsg.cvs20100315-2.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 | ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
(in-package :clim-internals)
(defclass graft (sheet-multiple-child-mixin mirrored-sheet-mixin basic-sheet)
((orientation :initform :default
:initarg :orientation
:reader graft-orientation)
(units :initform :device
:initarg :units
:reader graft-units)
(mirror :initarg :mirror)
)
)
(defmethod initialize-instance :after ((graft graft) &rest args)
(declare (ignore args))
(port-register-mirror (port graft) graft (slot-value graft 'mirror)))
; (setf (graft graft) graft))
(defun graftp (x)
(typep x 'graft))
(defmethod graft ((graft graft))
graft)
(defmethod sheet-grafted-p ((sheet basic-sheet))
(if (sheet-parent sheet)
(sheet-grafted-p (sheet-parent sheet))
nil))
(defmethod sheet-grafted-p ((graft graft))
t)
(defmethod sheet-viewable-p ((graft graft))
(sheet-enabled-p graft))
(defun find-graft (&key (port nil)
(server-path *default-server-path*)
(orientation :default)
(units :device))
(if (null port)
(setq port (find-port :server-path server-path)))
(block find-graft
(map-over-grafts #'(lambda (graft)
(if (and (eq orientation (graft-orientation graft))
(eq units (graft-units graft)))
(return-from find-graft graft)))
port)
(return-from find-graft (make-graft port :orientation orientation :units units))))
(defun map-over-grafts (function port)
(mapc function (port-grafts port)))
(defmacro with-graft-locked (graft &body body)
`(let ((graft ,graft))
,@body))
#-(and)
(defmethod graft-width ((graft graft) &key (units :device))
(if (eq units :device)
1000
1))
#-(and)
(defmethod graft-height ((graft graft) &key (units :device))
(if (eq units :device)
1000
1))
(defun graft-pixels-per-millimeter (graft)
;; We assume square pixels here --GB
(/ (graft-width graft :units :device)
(graft-width graft :units :millimeters)))
(defun graft-pixels-per-inch (graft)
;; We assume square pixels here --GB
(/ (graft-width graft :units :device)
(graft-width graft :units :inches)))
(defmethod sheet-native-transformation ((sheet graft))
+identity-transformation+)
(defmethod sheet-native-region ((sheet graft))
+everywhere+)
|