/[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.1.1.1 - (show annotations) (vendor branch)
Mon Apr 25 19:16:08 2011 UTC (2 years, 11 months ago) by rklochkov
Branch: slavsoft
CVS Tags: initial
Changes since 1.1: +0 -0 lines

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

  ViewVC Help
Powered by ViewVC 1.1.5