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

Contents of /gtk-cffi/examples/dialog.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 :gtk-cffi)
2
3 (defpackage :test-dialog
4 (:use #:common-lisp #:gtk-cffi))
5
6 (in-package :test-dialog)
7
8 (gtk-init)
9
10 (defun login ()
11 (loop
12 :for count :from 0 :to 2
13 :do (destructuring-bind (username password)
14 (get-data "Login" '("Username:" "Password:"))
15 (if (and (string= username "user1")
16 (string= password "pass1"))
17 (return t)
18 (show-message
19 nil
20 (format
21 nil
22 (format nil "~@{~A~%~}"
23 "Incorrect username and password!"
24 "Entered: username=~a"
25 "password=~a") username password)))))
26 nil)
27
28
29 (defun get-data (title field-labels)
30 (let ((dialog (make-instance 'dialog :name title :flags :modal)))
31 (setf (win-position dialog) :center-always)
32 (let ((top-area (v-box dialog))
33 (h-box (make-instance 'h-box)))
34 (pack top-area h-box)
35 (let ((stock (make-instance 'image
36 :stock-id "dialog-question"
37 :icon-size :dialog)))
38 (pack h-box stock :fill nil :expand nil)
39 (let ((table (make-instance 'table))
40 (input nil)
41 (row 0))
42 (mapc
43 (lambda (field-label)
44 (let ((label (make-instance 'label :text field-label)))
45 (setf (alignment label) '(0 0))
46 (attach table label
47 :left 0 :right 1
48 :top row :bottom (+ row 1))
49 (push (make-instance 'entry) input)
50 (attach table (car input)
51 :left 1 :right 2
52 :top row :bottom (+ row 1))
53 (when (search "password" field-label :test #'char-equal)
54 (setf (visibility (car input)) nil)))
55 (incf row)) field-labels)
56 (pack h-box table)
57 (add-button dialog :ok :ok)
58 (setf (has-separator dialog) nil)
59 (show dialog)
60 (run dialog)
61 (let ((data (mapcar (lambda (x) (text x)) (nreverse input))))
62 (destroy dialog)
63 data))))))
64
65 (format t "~a~%" (login))
66 (g-lib-cffi:timeout-add :idle #'gtk-main-quit)
67 (gtk-main)
68
69

  ViewVC Help
Powered by ViewVC 1.1.5