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