/[gtk-cffi]/gtk-cffi/examples/load-1c-txt.lisp
ViewVC logotype

Contents of /gtk-cffi/examples/load-1c-txt.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Fri Aug 26 17:16:13 2011 UTC (2 years, 7 months ago) by rklochkov
Branch: MAIN
CVS Tags: HEAD
Changes since 1.1: +7 -4 lines
Added GTK3 support. Dropped GTK2 support.
Refactored CFFI layer.
1 (asdf:oos 'asdf:load-op :gtk-cffi)
2 ;(declaim (optimize speed))
3 (defpackage #:load-1c-text
4 (:use #:common-lisp #:gtk-cffi))
5 (in-package #:load-1c-text)
6
7 (gtk-init)
8
9 (defparameter *model*
10 (make-instance 'list-store :columns '(:string :string :string :boolean)))
11 (defparameter *window* nil)
12
13 (defconstant +space+
14 (if (boundp '+space+) +space+
15 '(#\Space #\Tab #\Newline)))
16
17 (defun empty (str)
18 (string=
19 (string-trim +space+ str) ""))
20
21 (defun load-file (button)
22 (declare (ignore button))
23 (let ((f (filename (object-by-id :filename))) records)
24 (when (string= f "")
25 (return-from load-file))
26
27 (let ((filename (probe-file f))
28 progress-dialog
29 progress-bar maxpos)
30 (unless filename
31 (show-message *window* (format nil "No such file ~s" f)
32 :type :error)
33 (return-from load-file))
34 (format t "Loading file ~a~%" filename)
35 (setf progress-dialog
36 (gtk-model
37 'window
38 :title "Загрузка данных"
39 :transient-for *window*
40 :win-position :center-on-parent
41 :width 400
42 :kid (setf progress-bar (make-instance 'progress-bar))))
43 (show progress-dialog)
44 (with-open-file (s filename
45 #+sbcl :external-format #+sbcl :cp1251
46 #+clisp :external-format #+clisp charset:cp1251)
47 (setf maxpos (file-length s))
48 (handler-case
49 (do ((state :begin)
50 (text "")
51 (code "")
52 (descr "")
53 (str (read-line s) (read-line s))) (nil)
54 (macrolet
55 ((add-text (place str)
56 `(unless (empty ,str)
57 (setf ,place
58 (concatenate
59 'string
60 ,place
61 (format nil "~%")
62 (string-right-trim +space+ ,str))))))
63 (labels
64 ((prefix (str prefstr)
65 (and (> (length str) (length prefstr))
66 (string= (subseq str 0 (length prefstr))
67 prefstr)))
68 (sep (str)
69 (prefix str "------"))
70
71 (get-code (str)
72 (string-trim +space+
73 (subseq str (1+ (position #\: str)))))
74
75 (save ()
76 (setf (fraction progress-bar)
77 (/ (file-position s) maxpos))
78 (yield)
79 (push (list code descr
80 text (if (empty text) nil t)) records)
81 (setf code ""
82 descr ""
83 text "")))
84 ;(format t "~A ~A ~A~%" state (sep str) str)
85 (setf
86 state
87 (case state
88 (:begin (if (sep str) :code :begin))
89 (:code (if (prefix str "Код ошибки")
90 (progn
91 (setf code (get-code str)) :waittext)
92 :code))
93 (:waittext (if (prefix str "Описание") :descr :waittext))
94 (:descr (if (empty str) :text
95 (progn (add-text descr str) :descr)))
96 (:text (if (sep str) (progn (save) :code)
97 (progn (add-text text str) :text))))))))
98 (end-of-file () nil)))
99 (clear *model*)
100 (mapc (lambda (row) (append-values *model* row)) records)
101 (destroy progress-dialog))))
102
103 (defun select-file (button)
104 (declare (ignore button))
105 (let ((d (make-instance 'file-chooser-dialog
106 :action :open
107 :parent *window*
108 :title "Выберите файл ошибок 1С")))
109 (setf (filename d) (text (object-by-id :filename)))
110 (when (eq (run d :keep-alive t) :accept)
111 (setf (text (object-by-id :filename)) (filename d)))
112 (destroy d)))
113
114 ;(import 'gtk-cffi::expand)
115 (setf *window*
116 (gtk-model
117 'window :width 800
118 :height 600
119 :title "Загрузка из 1С"
120 :signals '(:destroy :gtk-main-quit)
121 ('v-box
122 :expand nil
123 :padding 5
124 ;; ('h-box
125 ;; :expand nil
126 ;; :padding 10
127 ;; ('label :text "Имя файла")
128 ;; :expand t
129 ;; ('entry :id :filename)
130 ;; nil
131 ;; :padding 0
132 ;; ('button :label "gtk-open"
133 ;; :type :stock :signals (list :clicked #'select-file))
134 ;; ('button :label "Загрузить" :signals (list :clicked #'load-file)))
135 ('file-chooser-button :title "Файл ошибок 1С" :action :open
136 :signals (list :file-set #'load-file)
137 :id :filename)
138 :expand t
139 ('v-paned :vexpand t
140 ('scrolled-window
141 ('tree-view :model *model*
142 :columns (list "Код ошибки" "Текст"
143 (list :title "Подробности"
144 :cell (make-instance 'cell-renderer-toggle)
145 :active 3))
146 :id :tree-view
147 :on-select (lambda (model iter &rest rest)
148 (declare (ignore rest))
149 (setf (text (buffer (object-by-id :text)))
150 (car (model-values model
151 :iter iter :col 2))))))
152 ('scrolled-window :vexpand t
153 ('text-view :id :text :vexpand t))))))
154
155
156 (show *window* :all t)
157 (gtk-main)
158

  ViewVC Help
Powered by ViewVC 1.1.5