git.chise.org Git - chise/xemacs-chise.git-/blob - tests/gtk/gnome-test.el

   1 (require 'gnome)
   2
   3 (gtk-define-test
   4  "GNOME Stock Pixmaps" gnome gnome-pixmaps nil
   5  (let ((hbox nil)
   6        (vbox nil)
   7        (widget nil)
   8        (label nil)
   9        (i 0))
  10    (mapc (lambda (b)
  11            (if (= (% i 5) 0)
  12                (progn
  13                  (setq hbox (gtk-hbutton-box-new))
  14                  (gtk-box-set-spacing hbox 5)
  15                  (gtk-container-add window hbox)))
  16
  17            (setq widget (gnome-stock-pixmap-widget-new window (car b))
  18                  vbox (gtk-vbox-new t 0)
  19                  label (gtk-label-new (cdr b)))
  20            (gtk-container-add hbox vbox)
  21            (gtk-container-add vbox widget)
  22            (gtk-container-add vbox label)
  23            (gtk-widget-show-all vbox)
  24            (setq i (1+ i)))
  25          gnome-stock-pixmaps)))
  26
  27 (gtk-define-test
  28  "GNOME Stock Buttons" gnome gnome-buttons nil
  29  (let ((hbbox nil)
  30        (button nil)
  31        (i 0))
  32    (mapc (lambda (b)
  33            (setq button (gnome-stock-button (car b)))
  34            (gtk-signal-connect button 'clicked (lambda (obj data)
  35                                                  (message "Stock GNOME Button: %s" data))
  36                                (cdr b))
  37            (if (= (% i 3) 0)
  38                (progn
  39                  (setq hbbox (gtk-hbutton-box-new))
  40                  (gtk-button-box-set-spacing hbbox 5)
  41                  (gtk-container-add window hbbox)))
  42
  43            (gtk-container-add hbbox button)
  44            (gtk-widget-show button)
  45            (setq i (1+ i)))
  46          gnome-stock-buttons)))
  47
  48 (gtk-define-test
  49  "GNOME About" gnome gnome-about t
  50  (setq window (gnome-about-new "XEmacs/GTK Test Application"
  51                                "1.0a"
  52                                "Copyright (C) 2000 Free Software Foundation"
  53                                '("William M. Perry <wmperry@gnu.org>"
  54                                  "Ichabod Crane")
  55                                "This is a comment string... what wonderful commentary you have my dear!"
  56                                "")))
  57
  58 (gtk-define-test
  59  "GNOME File Entry" gnome gnome-file-entry nil
  60  (let ((button (gnome-file-entry-new nil "Test browse dialog...")))
  61    (gtk-container-add window button)))
  62
  63 (gtk-define-test
  64  "GNOME Color Picker" gnome gnome-color-picker nil
  65  (let ((picker (gnome-color-picker-new))
  66        (hbox (gtk-hbox-new nil 0))
  67        (label (gtk-label-new "Please choose a color: ")))
  68
  69    (gtk-box-pack-start hbox label nil nil 2)
  70    (gtk-box-pack-start hbox picker t t 2)
  71    (gtk-container-add window hbox)
  72    (gtk-widget-show-all hbox)))
  73
  74 (gtk-define-test
  75  "GNOME Desktop Entry Editor" gnome gnome-dentry-edit nil
  76  (let* ((notebook (gtk-notebook-new)))
  77    (gnome-dentry-edit-new-notebook notebook)
  78    (gtk-container-add window notebook)))
  79
  80 (gtk-define-test
  81  "GNOME Date Edit" gnome gnome-date-entry nil
  82  (let ((date (gnome-date-edit-new 0 t t))
  83        button)
  84    (gtk-box-pack-start window date t t 0)
  85
  86    (setq button (gtk-check-button-new-with-label "Show time"))
  87    (gtk-signal-connect button 'clicked
  88                        (lambda (button date)
  89                          (let ((flags (gnome-date-edit-get-flags date)))
  90                            (if (gtk-toggle-button-get-active button)
  91                                (push 'show-time flags)
  92                              (setq flags (delq 'show-time flags)))
  93                            (gnome-date-edit-set-flags date flags))) date)
  94    (gtk-toggle-button-set-active button t)
  95    (gtk-box-pack-start window button nil nil 0)
  96
  97    (setq button (gtk-check-button-new-with-label "24 Hour format"))
  98    (gtk-signal-connect button 'clicked
  99                        (lambda (button date)
 100                          (let ((flags (gnome-date-edit-get-flags date)))
 101                            (if (gtk-toggle-button-get-active button)
 102                                (push '24-hr flags)
 103                              (setq flags (delq '24-hr flags)))
 104                            (gnome-date-edit-set-flags date flags))) date)
 105    (gtk-toggle-button-set-active button t)
 106    (gtk-box-pack-start window button nil nil 0)
 107
 108    (setq button (gtk-check-button-new-with-label "Week starts on monday"))
 109    (gtk-signal-connect button 'clicked
 110                        (lambda (button date)
 111                          (let ((flags (gnome-date-edit-get-flags date)))
 112                            (if (gtk-toggle-button-get-active button)
 113                                (push 'week-starts-on-monday flags)
 114                              (setq flags (delq 'week-starts-on-monday flags)))
 115                            (gnome-date-edit-set-flags date flags))) date)
 116    (gtk-toggle-button-set-active button t)
 117    (gtk-box-pack-start window button nil nil 0)))
 118
 119 (gtk-define-test
 120  "GNOME Font Picker" gnome gnome-font-picker nil
 121  (let ((hbox (gtk-hbox-new nil 5))
 122        (fp (gnome-font-picker-new))
 123        (label (gtk-label-new "Choose a font: "))
 124        (button nil))
 125    (gtk-box-pack-start hbox label t t 0)
 126    (gtk-box-pack-start hbox fp nil nil 2)
 127    (gnome-font-picker-set-title fp "Select a font...")
 128    (gnome-font-picker-set-mode fp 'font-info)
 129    (gtk-box-pack-start window hbox t t 0)
 130
 131    (setq button (gtk-check-button-new-with-label "Use font in label"))
 132    (gtk-signal-connect button 'clicked
 133                        (lambda (button fp)
 134                          (gnome-font-picker-fi-set-use-font-in-label
 135                           fp (gtk-toggle-button-get-active button) 14))
 136                        fp)
 137    (gtk-box-pack-start window button nil nil 0)
 138
 139    (setq button (gtk-check-button-new-with-label "Show size"))
 140    (gtk-signal-connect button 'clicked
 141                        (lambda (button fp)
 142                          (gnome-font-picker-fi-set-show-size
 143                           fp (gtk-toggle-button-get-active button)))
 144                        fp)
 145    (gtk-box-pack-start window button nil nil 0)))
 146
 147 (gtk-define-test
 148  "GNOME Application" gnome gnome-app t
 149  (setq window (gnome-app-new "XEmacs" "XEmacs/GNOME"))
 150  (let ((menubar (gtk-menu-bar-new))
 151        (contents nil)
 152        ;(toolbar-instance (specifier-instance top-toolbar))
 153        (toolbar nil)
 154        (item nil)
 155        (flushright nil))
 156    (mapc (lambda (node)
 157            (if (not node)
 158                (setq flushright t)
 159              (setq item (gtk-build-xemacs-menu node))
 160              (gtk-widget-show item)
 161              (if flushright (gtk-menu-item-right-justify item))
 162              (gtk-menu-append menubar item)))
 163          current-menubar)
 164
 165    (setq toolbar (gtk-toolbar-new 'horizontal 'both))
 166    (mapc (lambda (x)
 167            (let ((button (gtk-button-new))
 168                  (pixmap (gnome-stock-pixmap-widget-new toolbar x)))
 169              (gtk-container-add button pixmap)
 170              (gtk-toolbar-append-widget toolbar button (symbol-name x) nil)))
 171          '(open save print cut copy paste undo spellcheck srchrpl mail help))
 172
 173    (setq contents (gtk-hbox-new nil 5))
 174    (let ((hbox contents)
 175          (vbox (gtk-vbox-new nil 5))
 176          (frame nil)
 177          (label nil))
 178      (gtk-box-pack-start hbox vbox nil nil 0)
 179
 180      (setq frame (gtk-frame-new "Normal Label")
 181            label (gtk-label-new "This is a Normal label"))
 182      (gtk-container-add frame label)
 183      (gtk-box-pack-start vbox frame nil nil 0)
 184
 185      (setq frame (gtk-frame-new "Multi-line Label")
 186            label (gtk-label-new "This is a multi-line label.\nSecond line\nThird line"))
 187      (gtk-container-add frame label)
 188      (gtk-box-pack-start vbox frame nil nil 0)
 189
 190      (setq frame (gtk-frame-new "Left Justified Label")
 191            label (gtk-label-new "This is a Left-Justified\nMulti-line label.\nThird      line"))
 192      (gtk-label-set-justify label 'left)
 193      (gtk-container-add frame label)
 194      (gtk-box-pack-start vbox frame nil nil 0)
 195
 196      (setq frame (gtk-frame-new "Right Justified Label")
 197            label (gtk-label-new "This is a Right-Justified\nMulti-line label.\nFourth line, (j/k)"))
 198      (gtk-label-set-justify label 'right)
 199      (gtk-container-add frame label)
 200      (gtk-box-pack-start vbox frame nil nil 0)
 201
 202      ;; Start a second row so that we don't make a ridiculously tall window
 203      (setq vbox (gtk-vbox-new nil 5))
 204      (gtk-box-pack-start hbox vbox nil nil 0)
 205
 206      (setq frame (gtk-frame-new "Line wrapped label")
 207            label (gtk-label-new
 208                   (concat "This is an example of a line-wrapped label.  It should not be taking "
 209                           "up the entire             " ;;; big space to test spacing
 210                           "width allocated to it, but automatically wraps the words to fit.  "
 211                           "The time has come, for all good men, to come to the aid of their party.  "
 212                           "The sixth sheik's six sheep's sick.\n"
 213                           "     It supports multiple paragraphs correctly, and  correctly   adds "
 214                           "many          extra  spaces. ")))
 215      (gtk-label-set-line-wrap label t)
 216      (gtk-container-add frame label)
 217      (gtk-box-pack-start vbox frame nil nil 0)
 218
 219      (setq frame (gtk-frame-new "Filled, wrapped label")
 220            label (gtk-label-new
 221                   (concat
 222                    "This is an example of a line-wrapped, filled label.  It should be taking "
 223                    "up the entire              width allocated to it.  Here is a seneance to prove "
 224                    "my point.  Here is another sentence. "
 225                    "Here comes the sun, do de do de do.\n"
 226                    "    This is a new paragraph.\n"
 227                    "    This is another newer, longer, better paragraph.  It is coming to an end, "
 228                    "unfortunately.")))
 229      (gtk-label-set-justify label 'fill)
 230      (gtk-label-set-line-wrap label t)
 231      (gtk-container-add frame label)
 232      (gtk-box-pack-start vbox frame nil nil 0)
 233
 234      (setq frame (gtk-frame-new "Underlined label")
 235            label (gtk-label-new (concat "This label is underlined!\n"
 236                                         "This one is underlined in ÆüËÜ¸ì¤ÎÆþÍÑquite a funky fashion")))
 237      (gtk-label-set-justify label 'left)
 238      (gtk-label-set-pattern label "_________________________ _ _________ _ _____ _ __ __  ___ ____ _____")
 239      (gtk-container-add frame label)
 240      (gtk-box-pack-start vbox frame nil nil 0))
 241
 242    (gtk-widget-show-all toolbar)
 243    (gtk-widget-show-all menubar)
 244    (gtk-widget-show-all contents)
 245    (gnome-app-set-menus window menubar)
 246    (gnome-app-set-toolbar window toolbar)
 247    (gnome-app-set-contents window contents)))