/[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 - (hide 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 rklochkov 1.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