-;; Common Lisp bindings for GTK+ v2.0
-;; Copyright (C) 2001 Espen S. Johnsen <espen@users.sourceforge.org>
+;; Common Lisp bindings for GTK+ v2.x
+;; Copyright 2001-2006 Espen S. Johnsen <espen@users.sf.net>
;;
-;; This library is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU Lesser General Public
-;; License as published by the Free Software Foundation; either
-;; version 2 of the License, or (at your option) any later version.
+;; Permission is hereby granted, free of charge, to any person obtaining
+;; a copy of this software and associated documentation files (the
+;; "Software"), to deal in the Software without restriction, including
+;; without limitation the rights to use, copy, modify, merge, publish,
+;; distribute, sublicense, and/or sell copies of the Software, and to
+;; permit persons to whom the Software is furnished to do so, subject to
+;; the following conditions:
;;
-;; 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
-;; Lesser General Public License for more details.
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
;;
-;; You should have received a copy of the GNU Lesser 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
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-;; $Id: pango.lisp,v 1.3 2001-11-12 22:37:21 espen Exp $
+;; $Id: pango.lisp,v 1.16 2007-10-17 18:07:32 espen Exp $
(in-package "PANGO")
+(defconstant +pango-scale+ 1024)
+
+(defun device-to-pango-units (device-units)
+ (round (* device-units +pango-scale+)))
+
(eval-when (:compile-toplevel :load-toplevel :execute)
- (init-types-in-library "libpango.so" :ignore ("_pango_fribidi_get_type"))
+ (init-types-in-library pango "libpango-1.0" :prefix "pango_")
+ (init-types-in-library pango "libpangoxft-1.0" :prefix "pango_xft")
+ (init-types-in-library pango "libpangoft2-1.0" :prefix "pango_fc")
+ (init-types-in-library pango "libpangocairo-1.0" :prefix "pango_cairo"))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
(define-types-by-introspection "Pango"))
+
+(defclass font-description (boxed)
+ ((family
+ :allocation :virtual
+ :initarg :family :initform "Sans"
+ :getter "pango_font_description_get_family"
+ :setter "pango_font_description_set_family"
+ :boundp %font-description-family-boundp
+ :makunbound %font-description-family-makunbound
+ :accessor font-description-family
+ :type (static string))
+ (style
+ :allocation :virtual
+ :initarg :style :initform :normal
+ :getter "pango_font_description_get_style"
+ :setter "pango_font_description_set_style"
+ :boundp %font-description-style-boundp
+ :makunbound %font-description-style-makunbound
+ :accessor font-description-style
+ :type style)
+ (variant
+ :allocation :virtual
+ :initarg :variant :initform :normal
+ :getter "pango_font_description_get_variant"
+ :setter "pango_font_description_set_variant"
+ :boundp %font-description-variant-boundp
+ :makunbound %font-description-variant-makunbound
+ :accessor font-description-variant
+ :type variant)
+ (weight
+ :allocation :virtual :initform :normal
+ :initarg :weight
+ :getter "pango_font_description_get_weight"
+ :setter "pango_font_description_set_weight"
+ :boundp %font-description-weight-boundp
+ :makunbound %font-description-weight-makunbound
+ :accessor font-description-weight
+ :type weight)
+ (stretch
+ :allocation :virtual :initform :normal
+ :initarg :stretch
+ :getter "pango_font_description_get_stretch"
+ :setter "pango_font_description_set_stretch"
+ :boundp %font-description-stretch-boundp
+ :makunbound %font-description-stretch-makbound
+ :accessor font-description-stretch
+ :type stretch)
+ (size
+ :allocation :virtual
+; :initarg :size :initform 16 ; handled by initialize instance
+; :setter (setf font-description-size)
+ :setter %set-font-description-size
+ :getter "pango_font_description_get_size"
+ :boundp %font-description-size-boundp
+ :makunbound %font-description-size-makunbound
+ :reader font-description-size
+ :type integer)
+ #?(pkg-exists-p "pango" :atleast-version "1.8.0")
+ (size-is-absolute-p
+ :allocation :virtual
+; :initarg :size-is-absolute :initform nil ; handled by initialize instance
+ :getter "pango_font_description_get_size_is_absolute"
+ :boundp %font-description-size-boundp
+ :reader font-description-size-is-absolute-p
+ :type boolean))
+ (:metaclass boxed-class))
+
+(defclass layout (gobject)
+ ((context
+ :allocation :virtual
+ :getter "pango_layout_get_context"
+ :reader layout-context
+ :type context)
+ (text
+ :allocation :virtual
+ :initarg :text
+ :getter "pango_layout_get_text"
+ :setter %layout-set-text
+ :accessor layout-text
+ :type (static string))
+ (attributes
+ :allocation :virtual
+ :initarg :attributes
+ :getter "pango_layout_get_attributes"
+ :setter "pango_layout_set_attributes"
+ :accessor layout-attributes
+ :type attr-list)
+ (font-description
+ :allocation :virtual
+ :initarg :font-description
+ :getter "pango_layout_get_font_description"
+ :setter "pango_layout_set_font_description"
+ :accessor layout-font-description
+ :type font-description)
+ (width
+ :allocation :virtual
+ :initarg :width
+ :getter "pango_layout_get_width"
+ :setter "pango_layout_set_width"
+ :unbound -1
+ :accessor layout-width
+ :type int)
+ (wrap
+ :allocation :virtual
+ :initarg :wrap
+ :getter "pango_layout_get_wrap"
+ :setter "pango_layout_set_wrap"
+ :accessor layout-wrap
+ :type wrap-mode)
+ (ellipsize
+ :allocation :virtual
+ :initarg :ellipsize
+ :getter "pango_layout_get_ellipsize"
+ :setter "pango_layout_set_ellipsize"
+ :accessor layout-ellipsize
+ :type ellipsize-mode)
+ (indent
+ :allocation :virtual
+ :initarg :indent
+ :getter "pango_layout_get_indent"
+ :setter "pango_layout_set_indent"
+ :accessor layout-indent
+ :type int)
+ (spacing
+ :allocation :virtual
+ :initarg :spacing
+ :getter "pango_layout_get_spacing"
+ :setter "pango_layout_set_spacing"
+ :accessor layout-spacing
+ :type int)
+ (justify
+ :allocation :virtual
+ :initarg :justify
+ :getter "pango_layout_get_justify"
+ :setter "pango_layout_set_justify"
+ :accessor layout-justify-p
+ :type boolean)
+ (auto-dir
+ :allocation :virtual
+ :initarg :auto-dir
+ :getter "pango_layout_get_auto_dir"
+ :setter "pango_layout_set_auto_dir"
+ :accessor layout-auto-dir-p
+ :type boolean)
+ (alignment
+ :allocation :virtual
+ :initarg :alignment
+ :getter "pango_layout_get_alignment"
+ :setter "pango_layout_set_alignment"
+ :accessor layout-alignment
+ :type alignment)
+ (tabs
+ :allocation :virtual
+ :initarg :tabs
+ :getter "pango_layout_get_tabs"
+ :setter "pango_layout_set_tabs"
+ :accessor layout-tabs
+ :type tab-array)
+ (single-paragraph
+ :allocation :virtual
+ :initarg :single-paragraph
+ :getter "pango_layout_get_single_paragraph_mode"
+ :setter "pango_layout_set_single_paragraph_mode"
+ :accessor layout-single-paragraph-p
+ :type boolean))
+ (:metaclass gobject-class))
+
+(defclass cairo-font-map (interface)
+ ((resolution
+ :allocation :virtual
+ :getter "pango_cairo_font_map_get_resolution"
+ :setter "pango_cairo_font_map_set_resolution"
+ :accessor cairo-font-map-resolution
+ :type double-float))
+ (:metaclass interface-class))
+
+
+;;;; Font description
+
+(defmethod initialize-instance ((desc font-description) &key (size 16) size-is-absolute)
+ (call-next-method)
+ (setf (font-description-size desc size-is-absolute) size))
+
+(defbinding %font-description-new () pointer)
+
+(defmethod allocate-foreign ((desc font-description) &rest initargs)
+ (declare (ignore initargs))
+ (%font-description-new))
+
+(defbinding %font-description-get-set-fields () font-mask
+ (desc font-description))
+
+(defun %font-description-family-boundp (desc)
+ (find :family (%font-description-get-set-fields desc)))
+
+(defun %font-description-style-boundp (desc)
+ (find :style (%font-description-get-set-fields desc)))
+
+(defun %font-description-variant-boundp (desc)
+ (find :variant (%font-description-get-set-fields desc)))
+
+(defun %font-description-weight-boundp (desc)
+ (find :weight (%font-description-get-set-fields desc)))
+
+(defun %font-description-stretch-boundp (desc)
+ (find :stretch (%font-description-get-set-fields desc)))
+
+(defun %font-description-size-boundp (desc)
+ (find :size (%font-description-get-set-fields desc)))
+
+(defbinding %font-description-unset-fields () nil
+ (desc font-description)
+ (mask font-mask))
+
+(defun %font-description-family-makunbound (desc)
+ (%font-description-unset-fields desc :family))
+
+(defun %font-description-style-makunbound (desc)
+ (%font-description-unset-fields desc :style))
+
+(defun %font-description-variant-makunbound (desc)
+ (%font-description-unset-fields desc :variant))
+
+(defun %font-description-weight-makunbound (desc)
+ (%font-description-unset-fields desc :weight))
+
+(defun %font-description-stretch-makunbound (desc)
+ (%font-description-unset-fields desc :stretch))
+
+(defun %font-description-size-makunbound (desc)
+ (%font-description-unset-fields desc :size))
+
+(defbinding %font-description-set-size () nil
+ (desc font-description)
+ (size int))
+
+#?(pkg-exists-p "pango" :atleast-version "1.8.0")
+(defbinding %font-description-set-absolute-size () nil
+ (desc font-description)
+ (size double-float))
+
+(defun (setf font-description-size) (size desc &optional (absolute-p nil absolute-given-p))
+ (cond
+ (absolute-p
+ #?(pkg-exists-p "pango" :atleast-version "1.8.0")
+ (%font-description-set-absolute-size desc size)
+ #?-(pkg-exists-p "pango" :atleast-version "1.8.0")
+ (error "Setting of absolute font size requires at least Pango 1.8.0"))
+ (#?(pkg-exists-p "pango" :atleast-version "1.8.0") absolute-given-p
+ #?-(pkg-exists-p "pango" :atleast-version "1.8.0") t
+ (%font-description-set-size desc size))
+ #?(pkg-exists-p "pango" :atleast-version "1.8.0")
+ (t (if (font-description-size-is-absolute-p desc)
+ (%font-description-set-absolute-size desc size)
+ (%font-description-set-size desc size))))
+ size)
+
+(defun %set-font-description-size (size desc)
+ (setf (font-description-size desc) size))
+
+(defbinding font-description-merge (desc merge-desc &optional replace-p) nil
+ (desc font-description)
+ (merge-desc font-description)
+ (replace-p boolean))
+
+(defbinding font-description-better-match () boolean
+ (desc font-description)
+ (old-math font-description)
+ (new-math font-description))
+
+(defbinding font-description-from-string () font-description
+ (desc string))
+
+(defbinding font-description-to-string () string
+ (desc font-description))
+
+(defbinding font-description-copy () font-description
+ (font-description font-description))
+
+(defun ensure-font-description (font-description &optional copy-p)
+ (etypecase font-description
+ (font-description (if copy-p
+ (font-description-copy font-description)
+ font-description))
+ (string (font-description-from-string font-description))
+ (list (apply #'make-instance 'font-description font-description))))
+
+
+;;;; Layout
+
+(defmethod initialize-instance ((layout layout) &key markup)
+ (call-next-method)
+ (when markup
+ (layout-set-markup layout markup)))
+
+(defmethod allocate-foreign ((layout layout) &key context)
+ (etypecase context
+ (context (%layout-new context))
+ (cairo:context (%cairo-create-layout context))))
+
+(defbinding %layout-new () pointer
+ (context context))
+
+(defbinding layout-copy () (referenced layout)
+ (layout layout))
+
+(defbinding layout-context-changed () nil
+ (layout layout))
+
+(defbinding %layout-set-text (text layout) nil
+ (layout layout)
+ (text string)
+ (-1 int))
+
+(defbinding layout-set-markup () nil
+ (layout layout)
+ (markup string)
+ (-1 int))
+
+(defbinding layout-get-size () nil
+ (layout layout)
+ (width int :out)
+ (height int :out))
+
+(defbinding layout-get-pixel-size () nil
+ (layout layout)
+ (width int :out)
+ (height int :out))
+
+
+
+;;; Cairo Rendering
+
+(defbinding (cairo-create-font-map "pango_cairo_font_map_new")
+ () (referenced font-map))
+
+(defbinding cairo-font-map-get-default () font-map)
+
+(defbinding cairo-font-map-create-context () (referenced context)
+ (font-map cairo-font-map))
+
+(defbinding (cairo-context-resolution "pango_cairo_context_get_resolution")
+ () double-float
+ (context context))
+
+(defbinding %cairo-context-set-resolution () nil
+ (context context)
+ (dpi double-float))
+
+(defun (setf cairo-context-resolution) (dpi context)
+ (%cairo-context-set-resolution context dpi))
+
+(defbinding (cairo-context-font-options "pango_cairo_context_get_font_options")
+ () cairo:font-options
+ (context context))
+
+(defbinding %cairo-context-set-font-options () nil
+ (context context)
+ (font-options cairo:font-options))
+
+(defun (setf cairo-context-font-options) (font-options context)
+ (%cairo-context-set-font-options context font-options))
+
+(defbinding %cairo-create-layout () pointer
+ (cr cairo:context))
+
+(defbinding cairo-update-layout () nil
+ (cr cairo:context)
+ (layout layout))
+
+(defbinding cairo-show-glyph-string () nil
+ (cr cairo:context)
+ (font font)
+ (glyphs glyph-string))
+
+(defbinding cairo-show-layout-line () nil
+ (cr cairo:context)
+ (line layout-line))
+
+(defbinding cairo-show-layout () nil
+ (cr cairo:context)
+ (layout layout))
+
+(defbinding cairo-show-error-underline () nil
+ (cr cairo:context)
+ (x double-float)
+ (y double-float)
+ (width double-float)
+ (height double-float))
+
+(defbinding cairo-glyph-string-path () nil
+ (cr cairo:context)
+ (font font)
+ (glyphs glyph-string))
+
+(defbinding cairo-layout-line-path () nil
+ (cr cairo:context)
+ (line layout-line))
+
+(defbinding cairo-layout-path () nil
+ (cr cairo:context)
+ (layout layout))
+
+(defbinding cairo-error-underline-path () nil
+ (cr cairo:context)
+ (x double-float)
+ (y double-float)
+ (width double-float)
+ (height double-float))
+
~mdw / clg / blobdiff