/usr/share/guile-gnome-2/gnome/gtk.scm is in guile-gnome2-gtk 2.16.4-1.
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 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 | ;; guile-gnome
;; Copyright (C) 2003,2004,2009 Andy Wingo <wingo at pobox dot com>
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2 of
;; the License, or (at your option) any later version.
;;
;; This program 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 General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact:
;;
;; Free Software Foundation Voice: +1-617-542-5942
;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
;; Boston, MA 02111-1307, USA gnu@gnu.org
;;; Commentary:
;;
;;A GTK+ 2.x wrapper for Guile.
;;
;;; Code:
(define-module (gnome gtk)
#:use-module (oop goops)
#:use-module (gnome gobject)
#:use-module (gnome gobject generics)
#:use-module (gnome gobject utils)
#:use-module (gnome gw support modules)
#:export (<guile-gtk-tree-model>
on-get-flags on-get-n-columns on-get-column-type
on-get-iter on-get-path on-get-value on-iter-next
on-iter-children on-iter-has-child on-iter-n-children
on-iter-nth-child on-iter-parent
gtk-tree-or-list-store-set
gtk-text-buffer-create-tag create-tag
gtk-stock-id))
(define-macro (time-debug . forms)
`(begin ,@forms))
(eval-when (expand load eval)
(time-debug (use-modules (gnome gw gdk)))
(time-debug (use-modules (gnome gw gtk)))
(re-export-modules (gnome gw gdk)
(gnome gw gtk)))
;; Support explicit object destruction.
(define-method (initialize (instance <gtk-object>) initargs)
(next-method)
(connect instance 'destroy
(lambda args
(gtype-instance-destroy! instance))))
(define <guile-gtk-tree-model> <guile-gtk-generic-tree-model>)
;; FIXME: doc me!
(define-generic-with-docs on-get-flags
"")
(define-generic-with-docs on-get-n-columns
"")
(define-generic-with-docs on-get-column-type
"")
(define-generic-with-docs on-get-iter
"")
(define-generic-with-docs on-get-path
"")
(define-generic-with-docs on-get-value
"")
(define-generic-with-docs on-iter-next
"")
(define-generic-with-docs on-iter-children
"")
(define-generic-with-docs on-iter-has-child
"")
(define-generic-with-docs on-iter-n-children
"")
(define-generic-with-docs on-iter-nth-child
"")
(define-generic-with-docs on-iter-parent
"")
;; Support tree models written in guile.
(define-method (on-get-flags (obj <guile-gtk-tree-model>))
(make <gtk-tree-model-flags> #:value 0))
;; Miscellany.
(define (gtk-tree-or-list-store-set store iter . args)
(or (even? (length args)) (scm-error 'gruntime-error #f "Invalid arguments" '() #f))
(let loop ((args args))
(if (eq? args '())
*unspecified*
(begin
(set-value store iter (car args) (cadr args))
(loop (cddr args))))))
(define-method (set (store <gtk-list-store>) (iter <gtk-tree-iter>) . args)
(apply gtk-tree-or-list-store-set store iter args))
(define-method (set (store <gtk-tree-store>) (iter <gtk-tree-iter>) . args)
(apply gtk-tree-or-list-store-set store iter args))
(define (gtk-text-buffer-create-tag buffer tag-name . properties)
(let ((tag (make <gtk-text-tag> #:name tag-name)))
(if (not (even? (length properties)))
(scm-error 'gruntime-error #f "Invalid property list: ~A" properties #f))
(add (get-tag-table buffer) tag)
(let loop ((props properties))
(if (null? props)
tag
(begin
(set tag (car props) (cadr props))
(loop (cddr props)))))))
(define-method (create-tag (buffer <gtk-text-buffer>) tag-name . properties)
(apply gtk-text-buffer-create-tag buffer tag-name properties))
(eval-when (expand load eval)
(export create-tag))
(define (gtk-stock-id nick)
(string-append "gtk-" (symbol->string nick)))
|