mdw@git.distorted.org.uk Git - clg/blame_incremental

... / ...

Commit	Line	Data
	1	;; Common Lisp bindings for GTK+ v2.0
	2	;; Copyright (C) 1999-2005 Espen S. Johnsen <espen@users.sf.net>
	3	;;
	4	;; This library is free software; you can redistribute it and/or
	5	;; modify it under the terms of the GNU Lesser General Public
	6	;; License as published by the Free Software Foundation; either
	7	;; version 2 of the License, or (at your option) any later version.
	8	;;
	9	;; This library is distributed in the hope that it will be useful,
	10	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	11	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	12	;; Lesser General Public License for more details.
	13	;;
	14	;; You should have received a copy of the GNU Lesser General Public
	15	;; License along with this library; if not, write to the Free Software
	16	;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
	17
	18	;; $Id: testgtk.lisp,v 1.29 2005-04-21 12:30:23 espen Exp $
	19
	20	#+sbcl(require :gtk)
	21	#+cmucl(asdf:oos 'asdf:load-op :gtk)
	22
	23	(defpackage "TESTGTK"
	24	(:use "COMMON-LISP" "GTK"))
	25
	26	(in-package "TESTGTK")
	27
	28	(defmacro define-toplevel (name (window title &rest initargs) &body body)
	29	`(let ((,window nil))
	30	(defun ,name ()
	31	(unless ,window
	32	(setq ,window (make-instance 'window :title ,title ,@initargs :show-children t))
	33	(signal-connect ,window 'destroy #'(lambda () (setq ,window nil)))
	34	,@body)
	35
	36	(when ,window
	37	(if (not (widget-visible-p ,window))
	38	(widget-show ,window)
	39	(widget-hide ,window))))))
	40
	41
	42	(defmacro define-dialog (name (dialog title &optional (class 'dialog)
	43	&rest initargs)
	44	&body body)
	45	`(let ((,dialog nil))
	46	(defun ,name ()
	47	(unless ,dialog
	48	(setq ,dialog (make-instance ,class :title ,title ,@initargs :show-children t))
	49	(signal-connect ,dialog 'destroy #'(lambda () (setq ,dialog nil)))
	50	,@body)
	51
	52	(when ,dialog
	53	(if (not (widget-visible-p ,dialog))
	54	(widget-show ,dialog)
	55	(widget-hide ,dialog))))))
	56
	57
	58	(defmacro define-simple-dialog (name (dialog title &rest initargs) &body body)
	59	`(define-dialog ,name (,dialog ,title 'dialog ,@initargs)
	60	,@body
	61	(dialog-add-button ,dialog "gtk-close" #'widget-destroy :object t)))
	62
	63
	64
	65	;;; Pixmaps used in some of the tests
	66
	67	(defvar gtk-mini-xpm
	68	#("15 20 17 1"
	69	" c None"
	70	". c #14121F"
	71	"+ c #278828"
	72	"@ c #9B3334"
	73	"# c #284C72"
	74	"$ c #24692A"
	75	"% c #69282E"
	76	"& c #37C539"
	77	"* c #1D2F4D"
	78	"= c #6D7076"
	79	"- c #7D8482"
	80	"; c #E24A49"
	81	"> c #515357"
	82	", c #9B9C9B"
	83	"' c #2FA232"
	84	") c #3CE23D"
	85	"! c #3B6CCB"
	86	" "
	87	" ***> "
	88	" >.!!! "
	89	" **....#= "
	90	" !.!!!**!!# "
	91	" .!!#!#!!!!# "
	92	" @%#!.##.*!!$& "
	93	" @;%!.#!#')) "
	94	" @;;@%!!*$&)'' "
	95	" @%.%@%$'&)$+' "
	96	" @;...@$'')+ "
	97	" @;%..@$+*.')$ "
	98	" @;%%;;$+..$)# "
	99	" @;%%;@$$$'.$# "
	100	" %;@@;;$$+))&* "
	101	" %;;;@+$&)&* "
	102	" %;;@'))+> "
	103	" %;@'&# "
	104	" >%$$ "
	105	" >= "))
	106
	107	(defvar book-closed-xpm
	108	#("16 16 6 1"
	109	" c None s None"
	110	". c black"
	111	"X c red"
	112	"o c yellow"
	113	"O c #808080"
	114	"# c white"
	115	" "
	116	" .. "
	117	" ..XX. "
	118	" ..XXXXX. "
	119	" ..XXXXXXXX. "
	120	".ooXXXXXXXXX. "
	121	"..ooXXXXXXXXX. "
	122	".X.ooXXXXXXXXX. "
	123	".XX.ooXXXXXX.. "
	124	" .XX.ooXXX..#O "
	125	" .XX.oo..##OO. "
	126	" .XX..##OO.. "
	127	" .X.#OO.. "
	128	" ..O.. "
	129	" .. "
	130	" "))
	131
	132	(defvar mini-page-xpm
	133	#("16 16 4 1"
	134	" c None s None"
	135	". c black"
	136	"X c white"
	137	"o c #808080"
	138	" "
	139	" ....... "
	140	" .XXXXX.. "
	141	" .XoooX.X. "
	142	" .XXXXX.... "
	143	" .XooooXoo.o "
	144	" .XXXXXXXX.o "
	145	" .XooooooX.o "
	146	" .XXXXXXXX.o "
	147	" .XooooooX.o "
	148	" .XXXXXXXX.o "
	149	" .XooooooX.o "
	150	" .XXXXXXXX.o "
	151	" ..........o "
	152	" oooooooooo "
	153	" "))
	154
	155	(defvar book-open-xpm
	156	#("16 16 4 1"
	157	" c None s None"
	158	". c black"
	159	"X c #808080"
	160	"o c white"
	161	" "
	162	" .. "
	163	" .Xo. ... "
	164	" .Xoo. ..oo. "
	165	" .Xooo.Xooo... "
	166	" .Xooo.oooo.X. "
	167	" .Xooo.Xooo.X. "
	168	" .Xooo.oooo.X. "
	169	" .Xooo.Xooo.X. "
	170	" .Xooo.oooo.X. "
	171	" .Xoo.Xoo..X. "
	172	" .Xo.o..ooX. "
	173	" .X..XXXXX. "
	174	" ..X....... "
	175	" .. "
	176	" "))
	177
	178
	179
	180	;;; Button box
	181
	182	(defun create-bbox-in-frame (class frame-label spacing width height layout)
	183	(declare (ignore width height))
	184	(make-instance 'frame
	185	:label frame-label
	186	:child (make-instance class
	187	:border-width 5 :layout-style layout :spacing spacing
	188	:child (make-instance 'button :stock "gtk-ok")
	189	:child (make-instance 'button :stock "gtk-cancel")
	190	:child (make-instance 'button :stock "gtk-help"))))
	191
	192	(define-toplevel create-button-box (window "Button Boxes")
	193	(make-instance 'v-box
	194	:parent window :border-width 10 :spacing 10
	195	:child (make-instance 'frame
	196	:label "Horizontal Button Boxes"
	197	:child (make-instance 'v-box
	198	:border-width 10 :spacing 10
	199	:children (mapcar
	200	#'(lambda (args)
	201	(apply #'create-bbox-in-frame
	202	'h-button-box args))
	203	'(("Spread" 40 85 20 :spread)
	204	("Edge" 40 85 20 :edge)
	205	("Start" 40 85 20 :start)
	206	("End" 40 85 20 :end)))))
	207	:child (make-instance 'frame
	208	:label "Vertical Button Boxes"
	209	:child (make-instance 'h-box
	210	:border-width 10 :spacing 10
	211	:children (mapcar
	212	#'(lambda (args)
	213	(apply #'create-bbox-in-frame
	214	'v-button-box args))
	215	'(("Spread" 30 85 20 :spread)
	216	("Edge" 30 85 20 :edge)
	217	("Start" 30 85 20 :start)
	218	("End" 30 85 20 :end)))))))
	219
	220
	221	;; Buttons
	222
	223	(define-simple-dialog create-buttons (dialog "Buttons")
	224	(let ((table (make-instance 'table
	225	:n-rows 3 :n-columns 3 :homogeneous nil
	226	:row-spacing 5 :column-spacing 5 :border-width 10
	227	:parent dialog))
	228	(buttons (loop
	229	for n from 1 to 10
	230	collect (make-instance 'button
	231	:label (format nil "button~D" (1+ n))))))
	232
	233	(dotimes (column 3)
	234	(dotimes (row 3)
	235	(let ((button (nth (+ (* 3 row) column) buttons))
	236	(button+1 (nth (mod (+ (* 3 row) column 1) 9) buttons)))
	237	(signal-connect button 'clicked
	238	#'(lambda ()
	239	(if (widget-visible-p button+1)
	240	(widget-hide button+1)
	241	(widget-show button+1))))
	242	(table-attach table button column (1+ column) row (1+ row)
	243	:options '(:expand :fill)))))))
	244
	245
	246	;; Calenadar
	247
	248	(define-simple-dialog create-calendar (dialog "Calendar")
	249	(make-instance 'v-box
	250	:parent dialog :border-width 10
	251	:child (make-instance 'calendar)))
	252
	253
	254	;;; Check buttons
	255
	256	(define-simple-dialog create-check-buttons (dialog "Check Buttons")
	257	(make-instance 'v-box
	258	:border-width 10 :spacing 10 :parent dialog
	259	:children (loop
	260	for n from 1 to 3
	261	collect (make-instance 'check-button
	262	:label (format nil "Button~D" n)))))
	263
	264
	265
	266	;;; Color selection
	267
	268	(define-dialog create-color-selection (dialog "Color selection dialog"
	269	'color-selection-dialog
	270	:allow-grow nil :allow-shrink nil
	271	:show-children nil)
	272	(with-slots (colorsel) dialog
	273	(let ((button (make-instance 'check-button :label "Show Opacity")))
	274	(dialog-add-action-widget dialog button
	275	#'(lambda ()
	276	(setf
	277	(color-selection-has-opacity-control-p colorsel)
	278	(toggle-button-active-p button)))))
	279
	280	(let ((button (make-instance 'check-button :label "Show Palette")))
	281	(dialog-add-action-widget dialog button
	282	#'(lambda ()
	283	(setf
	284	(color-selection-has-palette-p colorsel)
	285	(toggle-button-active-p button)))))
	286
	287	(signal-connect dialog :ok
	288	#'(lambda ()
	289	(let ((color (color-selection-current-color colorsel)))
	290	(format t "Selected color: ~A~%" color)
	291	(setf (color-selection-current-color colorsel) color)
	292	(widget-hide dialog))))
	293
	294	(signal-connect dialog :cancel #'widget-destroy :object t)))
	295
	296
	297	;;; Cursors
	298
	299	(defun clamp (n min-val max-val)
	300	(declare (number n min-val max-val))
	301	(max (min n max-val) min-val))
	302
	303	(defun set-cursor (spinner drawing-area label)
	304	(let ((cursor
	305	(glib:int-enum
	306	(logand (clamp (spin-button-value-as-int spinner) 0 152) #xFE)
	307	'gdk:cursor-type)))
	308	(setf (label-label label) (string-downcase cursor))
	309	(setf (widget-cursor drawing-area) cursor)))
	310
	311	(defun cursor-expose (drawing-area event)
	312	(declare (ignore event))
	313	(multiple-value-bind (width height)
	314	(widget-get-size-allocation drawing-area)
	315	(let* ((window (widget-window drawing-area))
	316	(style (widget-style drawing-area))
	317	(white-gc (style-white-gc style))
	318	(gray-gc (style-bg-gc style :normal))
	319	(black-gc (style-black-gc style)))
	320	(gdk:draw-rectangle window white-gc t 0 0 width (floor height 2))
	321	(gdk:draw-rectangle window black-gc t 0 (floor height 2) width
	322	(floor height 2))
	323	(gdk:draw-rectangle window gray-gc t (floor width 3)
	324	(floor height 3) (floor width 3)
	325	(floor height 3))))
	326	t)
	327
	328	(define-simple-dialog create-cursors (dialog "Cursors")
	329	(let ((spinner (make-instance 'spin-button
	330	:adjustment (adjustment-new
	331	0 0
	332	(1- (glib:enum-int :last-cursor 'gdk:cursor-type))
	333	2 10 0)))
	334	(drawing-area (make-instance 'drawing-area
	335	:width-request 80 :height-request 80
	336	:events '(:exposure :button-press)))
	337	(label (make-instance 'label :label "XXX")))
	338
	339	(signal-connect drawing-area 'expose-event #'cursor-expose :object t)
	340
	341	(signal-connect drawing-area 'button-press-event
	342	#'(lambda (event)
	343	(case (gdk:event-button event)
	344	(1 (spin-button-spin spinner :step-forward))
	345	(3 (spin-button-spin spinner :step-backward)))
	346	t))
	347
	348	(signal-connect drawing-area 'scroll-event
	349	#'(lambda (event)
	350	(case (gdk:event-direction event)
	351	(:up (spin-button-spin spinner :step-forward))
	352	(:down (spin-button-spin spinner :step-backward)))
	353	t))
	354
	355	(signal-connect spinner 'changed
	356	#'(lambda ()
	357	(set-cursor spinner drawing-area label)))
	358
	359	(make-instance 'v-box
	360	:parent dialog :border-width 10 :spacing 5
	361	:child (list
	362	(make-instance 'h-box
	363	:border-width 5
	364	:child (list
	365	(make-instance 'label :label "Cursor Value : ")
	366	:expand nil)
	367	:child spinner)
	368	:expand nil)
	369	:child (make-instance 'frame
	370	:label "Cursor Area" :label-xalign 0.5 :border-width 10
	371	:child drawing-area)
	372	:child (list label :expand nil))
	373
	374	(widget-realize drawing-area)
	375	(set-cursor spinner drawing-area label)))
	376
	377
	378	;;; Dialog
	379
	380	(let ((dialog nil))
	381	(defun create-dialog ()
	382	(unless dialog
	383	(setq dialog (make-instance 'dialog
	384	:title "Dialog" :default-width 200
	385	:button "Toggle"
	386	:button (list "gtk-ok" #'widget-destroy :object t)
	387	:signal (list 'destroy
	388	#'(lambda ()
	389	(setq dialog nil)))))
	390
	391	(let ((label (make-instance 'label
	392	:label "Dialog Test" :xpad 10 :ypad 10 :visible t
	393	:parent dialog)))
	394	(signal-connect dialog "Toggle"
	395	#'(lambda ()
	396	(if (widget-visible-p label)
	397	(widget-hide label)
	398	(widget-show label))))))
	399
	400	(if (widget-visible-p dialog)
	401	(widget-hide dialog)
	402	(widget-show dialog))))
	403
	404
	405	;; Entry
	406
	407	(define-simple-dialog create-entry (dialog "Entry")
	408	(let ((main (make-instance 'v-box
	409	:border-width 10 :spacing 10 :parent dialog)))
	410
	411	(let ((entry (make-instance 'entry :text "hello world" :parent main)))
	412	(editable-select-region entry 0 5) ; this has no effect when
	413	; entry is editable
	414	;; (editable-insert-text entry "great " 6)
	415	;; (editable-delete-text entry 6 12)
	416
	417	(let ((combo (make-instance 'combo-box-entry
	418	:parent main
	419	:content '("item0"
	420	"item1 item1"
	421	"item2 item2 item2"
	422	"item3 item3 item3 item3"
	423	"item4 item4 item4 item4 item4"
	424	"item5 item5 item5 item5 item5 item5"
	425	"item6 item6 item6 item6 item6"
	426	"item7 item7 item7 item7"
	427	"item8 item8 item8"
	428	"item9 item9"))))
	429	(with-slots (child) combo
	430	(setf (editable-text child) "hello world")
	431	(editable-select-region child 0)))
	432
	433	(flet ((create-check-button (label slot)
	434	(make-instance 'check-button
	435	:label label :active t :parent main
	436	:signal (list 'toggled
	437	#'(lambda (button)
	438	(setf (slot-value entry slot)
	439	(toggle-button-active-p button)))
	440	:object t))))
	441
	442	(create-check-button "Editable" 'editable)
	443	(create-check-button "Visible" 'visibility)
	444	(create-check-button "Sensitive" 'sensitive)))))
	445
	446
	447	;; Expander
	448
	449	(define-simple-dialog create-expander (dialog "Expander" :resizable nil)
	450	(make-instance 'v-box
	451	:parent dialog :spacing 5 :border-width 5
	452	:child (create-label "Expander demo. Click on the triangle for details.")
	453	:child (make-instance 'expander
	454	:label "Details"
	455	:child (create-label "Details can be shown or hidden."))))
	456
	457
	458	;; File chooser dialog
	459
	460	(define-dialog create-file-chooser (dialog "File Chooser" 'file-chooser-dialog)
	461	(file-chooser-add-filter dialog
	462	(make-instance 'file-filter :name "All files" :pattern "*"))
	463	(file-chooser-add-filter dialog
	464	(make-instance 'file-filter :name "Common Lisp source code"
	465	:patterns '(".lisp" ".lsp")))
	466
	467	(dialog-add-button dialog "gtk-cancel" #'widget-destroy :object t)
	468	(dialog-add-button dialog "gtk-ok"
	469	#'(lambda ()
	470	(if (slot-boundp dialog 'filename)
	471	(format t "Selected file: ~A~%" (file-chooser-filename dialog))
	472	(write-line "No files selected"))
	473	(widget-destroy dialog))))
	474
	475
	476	;; Font selection dialog
	477
	478	(define-toplevel create-font-selection (window "Font Button" :resizable nil)
	479	(make-instance 'h-box
	480	:parent window :spacing 8 :border-width 8
	481	:child (make-instance 'label :label "Pick a font")
	482	:child (make-instance 'font-button
	483	:use-font t :title "Font Selection Dialog")))
	484
	485
	486	;;; Icon View
	487
	488	#+gtk2.6
	489	(let ((file-pixbuf nil)
	490	(folder-pixbuf nil))
	491	(defun load-pixbufs ()
	492	(unless file-pixbuf
	493	(handler-case
	494	(setf
	495	file-pixbuf (gdk:pixbuf-load #p"clg:examples;gnome-fs-regular.png")
	496	folder-pixbuf (gdk:pixbuf-load #p"clg:examples;gnome-fs-directory.png"))
	497	(glib:glib-error (condition)
	498	(make-instance 'message-dialog
	499	:message-type :error :visible t
	500	:text "<b>Failed to load an image</b>"
	501	:secondary-text (glib:gerror-message condition)
	502	:signal (list :close #'widget-destroy :object t))
	503	(return-from load-pixbufs nil))))
	504	t)
	505
	506	(defun fill-store (store directory)
	507	(list-store-clear store)
	508	(let ((dir #+cmu(unix:open-dir directory)
	509	#+sbcl(sb-posix:opendir directory)))
	510	(unwind-protect
	511	(loop
	512	as filename = #+cmu(unix:read-dir dir)
	513	#+sbcl(let ((dirent (sb-posix:readdir dir)))
	514	(unless (sb-grovel::foreign-nullp dirent)
	515	(sb-posix:dirent-name dirent)))
	516	while filename
	517	unless (or (equal filename ".") (equal filename ".."))
	518	do (let* ((pathname (format nil "~A~A" directory filename))
	519	(directory-p
	520	#+cmu(eq (unix:unix-file-kind pathname) :directory)
	521	#+sbcl(sb-posix:s-isdir (sb-posix:stat-mode (sb-posix:stat pathname)))))
	522	(list-store-append store
	523	(vector
	524	filename
	525	(if directory-p folder-pixbuf file-pixbuf)
	526	directory-p))))
	527	#+cmu(unix:close-dir dir)
	528	#+sbcl(sb-posix:closedir dir))))
	529
	530	(defun sort-func (store a b)
	531	(let ((a-dir-p (tree-model-value store a 'directory-p))
	532	(b-dir-p (tree-model-value store b 'directory-p))
	533	(a-name (tree-model-value store a 'filename))
	534	(b-name (tree-model-value store b 'filename)))
	535	(cond
	536	((and a-dir-p (not b-dir-p)) :before)
	537	((and (not a-dir-p) b-dir-p) :after)
	538	((string< a-name b-name) :before)
	539	((string> a-name b-name) :after)
	540	(t :equal))))
	541
	542	(defun parent-dir (dir)
	543	(let ((end (1+ (position #\/ dir :from-end t :end (1- (length dir))))))
	544	(subseq dir 0 end)))
	545
	546	(define-toplevel create-icon-view (window "Icon View demo"
	547	:default-width 650
	548	:default-height 400)
	549	(if (not (load-pixbufs))
	550	(widget-destroy window)
	551	(let* ((directory "/")
	552	(store (make-instance 'list-store
	553	:column-types '(string gdk:pixbuf boolean)
	554	:column-names '(filename pixbuf directory-p)))
	555	(icon-view (make-instance 'icon-view
	556	:model store :selection-mode :multiple
	557	:text-column 'filename :pixbuf-column 'pixbuf))
	558	(up (make-instance 'tool-button
	559	:stock "gtk-go-up" :is-important t :sensitive nil))
	560	(home (make-instance 'tool-button
	561	:stock "gtk-home" :is-important t)))
	562	(tree-sortable-set-sort-func store :default #'sort-func)
	563	(tree-sortable-set-sort-column store :default :ascending)
	564	(fill-store store directory)
	565
	566	(signal-connect icon-view 'item-activated
	567	#'(lambda (path)
	568	(when (tree-model-value store path 'directory-p)
	569	(setq directory
	570	(concatenate 'string directory (tree-model-value store path 'filename) "/"))
	571	(fill-store store directory)
	572	(setf (widget-sensitive-p up) t))))
	573
	574	(signal-connect up 'clicked
	575	#'(lambda ()
	576	(unless (string= directory "/")
	577	(setq directory (parent-dir directory))
	578	(fill-store store directory)
	579	(setf
	580	(widget-sensitive-p home)
	581	(not (string= directory (namestring (truename #p"clg:")))))
	582	(setf (widget-sensitive-p up) (not (string= directory "/"))))))
	583
	584	(signal-connect home 'clicked
	585	#'(lambda ()
	586	(setq directory (namestring (truename #p"clg:")))
	587	(fill-store store directory)
	588	(setf (widget-sensitive-p up) t)
	589	(setf (widget-sensitive-p home) nil)))
	590
	591	(make-instance 'v-box
	592	:parent window
	593	:child (list
	594	(make-instance 'toolbar :child up :child home)
	595	:fill nil :expand nil)
	596	:child (make-instance 'scrolled-window
	597	:shadow-type :etched-in :policy :automatic
	598	:child icon-view))))))
	599
	600
	601	;;; Image
	602
	603	(define-toplevel create-image (window "Image" :resizable nil)
	604	(make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
	605
	606
	607	;;; Labels
	608
	609	(define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
	610	(flet ((create-label-in-frame (frame-label label-text &rest args)
	611	(list
	612	(make-instance 'frame
	613	:label frame-label
	614	:child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))
	615	:fill nil :expand nil)))
	616	(make-instance 'h-box
	617	:spacing 5 :parent window
	618	:child-args '(:fill nil :expand nil)
	619	:child (make-instance 'v-box
	620	:spacing 5
	621	:child (create-label-in-frame "Normal Label" "This is a Normal label")
	622	:child (create-label-in-frame "Multi-line Label"
	623	"This is a Multi-line label.
	624	Second line
	625	Third line")
	626	:child (create-label-in-frame "Left Justified Label"
	627	"This is a Left-Justified
	628	Multi-line.
	629	Third line"
	630	:justify :left)
	631	:child (create-label-in-frame "Right Justified Label"
	632	"This is a Right-Justified
	633	Multi-line.
	634	Third line"
	635	:justify :right))
	636	:child (make-instance 'v-box
	637	:spacing 5
	638	:child (create-label-in-frame "Line wrapped label"
	639	"This is an example of a line-wrapped label. It should not be taking up the entire width allocated to it, but automatically wraps the words to fit. The time has come, for all good men, to come to the aid of their party. The sixth sheik's six sheep's sick.
	640	It supports multiple paragraphs correctly, and correctly adds many extra spaces. "
	641	:wrap t)
	642
	643	:child (create-label-in-frame "Filled, wrapped label"
	644	"This is an example of a line-wrapped, filled label. It should be taking up the entire width allocated to it. Here is a seneance to prove my point. Here is another sentence. Here comes the sun, do de do de do.
	645	This is a new paragraph.
	646	This is another newer, longer, better paragraph. It is coming to an end, unfortunately."
	647	:justify :fill :wrap t)
	648
	649	:child (create-label-in-frame "Underlined label"
	650	(#+cmu glib:latin1-to-unicode #+sbcl identity
	651	"This label is underlined!
	652