/[gtk-cffi]/gtk-cffi/examples/editor.lisp
ViewVC logotype

Contents of /gtk-cffi/examples/editor.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Sat Sep 10 16:26:10 2011 UTC (2 years, 7 months ago) by rklochkov
Branch: MAIN
CVS Tags: HEAD
Changes since 1.3: +55 -8 lines
Some refactoring. Now we can use (show #(1 2 3)) or (show '(1 2 3)) to lookup
through the sequence in GTK list view
1 (asdf:oos 'asdf:load-op :gtk-cffi)
2 (asdf:oos 'asdf:load-op :babel)
3 (asdf:oos 'asdf:load-op :flexi-streams)
4
5
6 (defpackage #:editor
7 (:use #:common-lisp #:gtk-cffi #:g-object-cffi))
8 (in-package #:editor)
9
10
11 (gtk-init)
12
13 (defvar *window*)
14
15 (defun open-file (&rest rest)
16 (declare (ignore rest))
17 (let ((d (make-instance 'file-chooser-dialog
18 :action :open
19 :parent *window*
20 :title "Open file")))
21 (when (eq (run d) :accept)
22 (setf (text (buffer (object-by-id :main-text)))
23 (with-open-file (s (filename d) :element-type '(unsigned-byte 8))
24 (destroy d) ; filename fetched
25 (let ((res (make-array (file-length s)
26 :element-type '(unsigned-byte 8))))
27 (read-sequence res s)
28 (handler-case (babel:octets-to-string res :encoding :utf-8)
29 (t nil (flexi-streams:octets-to-string
30 res :external-format :koi8-r)))))))))
31
32
33 (defun save-file (&rest rest)
34 (format t "~a" rest))
35
36
37 (setq *window*
38 (gtk-model
39 'window :signals '(:destroy :gtk-main-quit)
40 :width 950 :height 600 :title "Editor"
41 ('v-box
42 :expand nil
43 ('menu-bar
44 ('menu-item
45 :label "File"
46 :submenu
47 (gtk-model
48 'menu
49 ('menu-item :label "Open"
50 :signals '(:activate open-file))
51 ('menu-item :label "Save"
52 :signals '(:activate save-file))
53 ('menu-item :label "Quit"
54 :signals `(:activate ,(lambda (&rest rest)
55 (declare (ignore rest))
56 (destroy *window*)))))))
57 :expand t
58 ('h-box
59 :expand nil
60 ;('h-paned
61 ('scrolled-window
62 ('tree-view))
63 :expand t
64 ('frame
65 ('v-box
66 :expand nil
67 ('label :text "Main window")
68 :expand t
69 ('scrolled-window
70 ('text-view :id :main-text))))
71 ('v-box
72 :expand nil
73 ('label :text "REPL")
74 :expand t
75 ('scrolled-window
76 ('text-view :id :text3))))
77 :expand nil
78 ('statusbar))))
79
80 ;(setf ;(text (buffer (object-by-id :text1))) "1"
81 ; (text (buffer (object-by-id :text2))) "2"
82 ; (text (buffer (object-by-id :text3))) "3")
83
84 (show *window*)
85 (gtk-main)
86
87
88

  ViewVC Help
Powered by ViewVC 1.1.5