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

Contents of /gtk-cffi/examples/rdbms.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, MAIN
CVS Tags: initial, HEAD
Changes since 1.1: +0 -0 lines

Initial release
1 (asdf:oos 'asdf:load-op :cl-rdbms)
2 (asdf:oos 'asdf:load-op :gtk-cffi)
3
4 (defpackage :test
5 (:use #:common-lisp #:gtk-cffi #:cffi-object #:g-object-cffi #:cl-rdbms)
6 (:shadowing-import-from #:gtk-cffi #:column-type))
7
8 (in-package :test)
9
10 (defvar *database*
11 (make-instance 'postgresql-postmodern
12 :connection-specification '(:database "monk"
13 :user-name "monk"
14 :password "")))
15 ;(enable-sql-syntax)
16
17
18 (gtk-init)
19
20 (defvar *model*
21 (make-instance 'list-store :columns '(:string :string
22 :string :string :uint)))
23
24 (defun process (row)
25 (list
26 (local-time:format-timestring nil
27 (aref row 0)
28 :format local-time:+asctime-format+)
29 (case (aref row 1)
30 (6 "TCP")
31 (17 "UDP")
32 (t (format nil "~a" (aref row 1))))
33 (format nil "~a:~a" (aref row 2) (aref row 3))
34 (format nil "~a:~a" (aref row 4) (aref row 5))
35 (aref row 6)))
36
37 ;(map nil (lambda (row)
38 ; (append-values *model* (process row)))
39 ; (with-transaction (execute (sql (select * traffic)))))
40
41
42
43 (defvar *window*
44 (gtk-model
45 'window :width 800
46 :height 600
47 :title "Траффик"
48 :signals '(:destroy :gtk-main-quit)
49 ('scrolled-window
50 ('tree-view :id :tree :model *model*
51 :columns '("Дата" "Протокол"
52 "Источник" "Приемник" "Размер")))))
53
54 (setf (gsignal *window* :show)
55 (lambda (&rest rest)
56 (declare (ignore rest))
57 (format t "Realized~%")
58 (let* (progress-bar
59 (progress-dialog
60 (gtk-model
61 'window
62 :title "Загрузка данных"
63 :transient-for *window*
64 :win-position :center-on-parent
65 :width 400
66 :kid (setf progress-bar (make-instance 'progress-bar)))))
67 (show progress-dialog)
68 (setf (model (object-by-id :tree)) nil)
69 (let*
70 ((table (with-transaction (execute (sql (select * traffic)))))
71 (ltable (- (length table) 1))
72 (table2 (loop
73 :for i :from 0 :to ltable
74 :collecting (process (aref table i))))
75 (i 0) (pos 0))
76 (mapcar
77 (lambda (x)
78 (when (> (incf i) 1024)
79 (setf i 0
80 (fraction progress-bar)
81 (/ (incf pos 1024) ltable))
82 (yield))
83 (append-values *model* x))
84 table2))
85 (setf (model (object-by-id :tree)) *model*)
86 (destroy progress-dialog))))
87 ;; (gsignal *window* :realize)
88 ;; (lambda (&rest rest)
89 ;; (declare (ignore rest))
90 ;; (format t "Realized~%")))
91
92
93
94 (show *window*)
95
96 (gtk-main)
97
98
99

  ViewVC Help
Powered by ViewVC 1.1.5