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