;; gtk-widget.el Version 1.0 ;; This code is under the license of the GNU GPL. A copy of this ;; license should be found somewhere in the code below. You all know ;; what it looks like, anyway... ;; ;;The truncate-string-to-width function is stolen from mule-util which ;;some people don't seem to have by default. It is also under the ;;terms of the GNU GPL ;;useful string-generation functions (eval-and-compile (unless (fboundp 'truncate-string-to-width) (defun truncate-string-to-width (str end-column &optional start-column padding) "Truncate string STR to end at column END-COLUMN. The optional 2nd arg START-COLUMN, if non-nil, specifies the starting column; that means to return the characters occupying columns START-COLUMN ... END-COLUMN of STR. The optional 3rd arg PADDING, if non-nil, specifies a padding character to add at the end of the result if STR doesn't reach column END-COLUMN, or if END-COLUMN comes in the middle of a character in STR. PADDING is also added at the beginning of the result if column START-COLUMN appears in the middle of a character in STR. If PADDING is nil, no padding is added in these cases, so the resulting string may be narrower than END-COLUMN." (or start-column (setq start-column 0)) (let ((len (length str)) (idx 0) (column 0) (head-padding "") (tail-padding "") ch last-column last-idx from-idx) (condition-case nil (while (< column start-column) (setq ch (aref str idx) column (+ column (char-width ch)) idx (1+ idx))) (args-out-of-range (setq idx len))) (if (< column start-column) (if padding (make-string end-column padding) "") (if (and padding (> column start-column)) (setq head-padding (make-string (- column start-column) padding))) (setq from-idx idx) (if (< end-column column) (setq idx from-idx) (condition-case nil (while (< column end-column) (setq last-column column last-idx idx ch (aref str idx) column (+ column (char-width ch)) idx (1+ idx))) (args-out-of-range (setq idx len))) (if (> column end-column) (setq column last-column idx last-idx)) (if (and padding (< column end-column)) (setq tail-padding (make-string (- end-column column) padding)))) (setq str (substring str from-idx idx)) (if padding (concat head-padding str tail-padding) str))))) (unless (fboundp 'truncate-string) (defalias 'truncate-string 'truncate-string-to-width) (make-obsolete 'truncate-string 'truncate-string-to-width))) (defun generate-buffer-name (widget-name prefix) (concat (downcase prefix) "-" (mapconcat (function (lambda (x) (if (char-equal x ?_) "-" (format "%c" x)))) widget-name ""))) (defun generate-allcaps-name (widget-name prefix) (concat (upcase prefix) "_" (upcase widget-name))) (defun generate-struct-name (widget-name prefix) (concat (capitalize prefix) (mapconcat (function (lambda (x) (if (char-equal x ?_) "" (format "%c" x)))) (capitalize widget-name) ""))) ;; This goes from GtkObject -> gtk_object (defun upcase-char (C) (and (string-lessp "A" (format "%c" C)) (string-lessp (format "%c" C) "Z"))) (truncate-string "fooo" (length "fooo") 1) (defun generate-parent-name (widget) (let ((retval (mapconcat (function (lambda (x) (if (upcase-char x) (concat "_" (char-to-string (downcase x))) (char-to-string x)))) widget ""))) ;There hasta be a better way to do this. ;but is there an easier way to cut off the first char. (truncate-string retval (length retval) 1))) ;;add stuff to the buffer (defun gtk-widget-add-license (license filename) (insert "/* " filename "\n * Copyright (C) " (format-time-string "%Y ") gtk-widget-author-name) (cond ((string= license "GPL") (insert GPL-END)) ((string= license "LGPL") (insert LGPL-END)) ((string= license "NONE") (insert "\n */\n")))) (defun gtk-widget-add-preprocessor (widget-name prefix) (let ((allcaps-name (generate-allcaps-name widget-name prefix))) (insert "#ifndef __" allcaps-name "_H__\n" "#define __" allcaps-name "_H__\n"))) (defun gtk-widget-add-includes (widget-name prefix body) (cond ((string= prefix "GTK") (insert "\n#include \n")) (t (insert "\n#include \n"))) (if body (insert "#include \"" (generate-buffer-name widget-name prefix) ".h\"\n") (insert "\n"))) (defun gtk-widget-add-cplusplus () (insert "#ifdef __cplusplus\nextern \"C\" {\n#pragma }\n#endif /* __cplusplus */\n\n")) (defun gtk-widget-add-macros (widget-name prefix virtual) ;are any macros not used in virtual fns? (let ((allcaps-name (generate-allcaps-name widget-name prefix)) (struct-name (generate-struct-name widget-name prefix))) (insert "#define " (upcase prefix) "_TYPE_" (upcase widget-name) "\t\t\t") (insert "(" (downcase allcaps-name) "_get_type ())\n") (insert "#define " allcaps-name "(obj)\t\t\t") (insert "(GTK_CHECK_CAST ((obj), " (upcase prefix) "_TYPE_" (upcase widget-name) ", " struct-name "))\n") (insert "#define " allcaps-name "_CLASS(klass)\t\t") (insert "(GTK_CHECK_CLASS_CAST ((klass), " (upcase prefix) "_TYPE_" (upcase widget-name) ", " struct-name "Class))\n") (insert "#define " (upcase prefix) "_IS_" (upcase widget-name) "(obj)\t\t\t") (insert "(GTK_CHECK_TYPE ((obj), " (upcase prefix) "_TYPE_" (upcase widget-name) "))\n") (insert "#define " (upcase prefix) "_IS_" (upcase widget-name) "_CLASS(klass)\t\t") (insert "(GTK_CHECK_CLASS_TYPE ((obj), " (upcase prefix) "_TYPE_" (upcase widget-name) "))\n\n\n"))) (defun gtk-widget-add-struct-defs (widget-name prefix inherited-widget signal-list) (let ((struct-name (generate-struct-name widget-name prefix))) (insert "typedef struct _" struct-name " " struct-name ";\n") (insert "typedef struct _" struct-name "Class " struct-name "Class;\n\n") (insert "struct _" struct-name "\n{\n") (insert " " inherited-widget " parent;\n") (insert "\n /* Put your own, widget-specific fields here */\n\n};\n") (insert "struct _" struct-name "Class\n{\n") (insert " " inherited-widget "Class parent_class;\n") (if signal-list (insert "\n /* Signals go here */\n")) (if signal-list (insert (mapconcat (function (lambda (x) (concat " void (*" (symbol-name x) ")\t(" struct-name " *" widget-name ");"))) signal-list "\n") "\n")) (insert "};\n\n\n"))) (defun gtk-widget-add-header-prototypes (widget-name prefix virtual) (insert "GtkType " (downcase prefix) "_" (downcase widget-name) "_get_type (void);\n") (if (not virtual) (insert "GtkWidget *" (downcase prefix) "_" (downcase widget-name) "_new (void);\n\n") (insert "\n"))) (defun gtk-widget-add-body-prototypes (widget-name prefix inherited-widget signal-list) (let ((struct-name (generate-struct-name widget-name prefix)) (real-struct-name (concat (downcase prefix) "_real_" (downcase widget-name) "_"))) ;The enums first if needed (if signal-list (insert "\nenum {\n " (upcase (mapconcat 'symbol-name signal-list ",\n ")) ",\n LAST_SIGNAL\n};\n\n")) ;prototypes next (insert "static void " (downcase prefix) "_" widget-name "_init\t\t(" struct-name "\t\t *" widget-name ");\n") (insert "static void " (downcase prefix) "_" widget-name "_class_init\t(" struct-name "Class\t *klass);\n") (if signal-list (insert (mapconcat (function (lambda (x) (concat "static void " real-struct-name (symbol-name x) "\t(" struct-name "\t\t *" widget-name ");\n"))) signal-list "") "")) (insert "\n\nstatic " inherited-widget "Class *parent_class = NULL;\n") (if signal-list (insert "static guint " widget-name "_signals[LAST_SIGNAL] = { 0 };\n")) )) (defun gtk-widget-add-gtk-init (widget-name prefix inherited-widget signal-list) (let ((struct-name (generate-struct-name widget-name prefix)) (parent-name (generate-parent-name inherited-widget)) (prewidget (concat (downcase prefix) "_" widget-name)) (real-struct-name (concat (downcase prefix) "_real_" (downcase widget-name) "_"))) (insert "\n\nGtkType\n" prewidget "_get_type (void)\n{\n" " static GtkType " widget-name "_type = 0;\n\n" " if (!" widget-name "_type)\n" " {\n" " static const GtkTypeInfo " widget-name "_info =\n" " {\n" " \"" struct-name "\",\n" " sizeof (" struct-name "),\n" " sizeof (" struct-name "Class),\n" " (GtkClassInitFunc) " prewidget "_class_init,\n" " (GtkObjectInitFunc) " prewidget "_init,\n" " /* reserved_1 */ NULL,\n" " /* reserved_2 */ NULL,\n" " (GtkClassInitFunc) NULL,\n" " };\n\n" " " widget-name "_type = gtk_type_unique (" parent-name "_get_type (), &" widget-name "_info);\n" " }\n\n" " return " widget-name "_type;\n}\n\n") ; Now we do class_init (insert "static void\n" prewidget "_class_init (" struct-name "Class *klass)\n" "{\n" " GtkObjectClass *object_class;\n\n" " object_class = (GtkObjectClass*) klass;\n\n" " parent_class = gtk_type_class (" (generate-parent-name inherited-widget) "_get_type ());\n\n") (if signal-list (insert (mapconcat (function (lambda (x) (concat " " widget-name "_signals[" (upcase (symbol-name x)) "] = \n" " gtk_signal_new (\"" (symbol-name x) "\",\n" " GTK_RUN_FIRST,\n" " object_class->type,\n" " GTK_SIGNAL_OFFSET (" struct-name "Class, " (symbol-name x) "),\n" " gtk_marshal_NONE__NONE,\n" " GTK_TYPE_NONE, 0);\n"))) signal-list ""))) (if signal-list (insert "\n\n gtk_object_class_add_signals (object_class, " widget-name "_signals, LAST_SIGNAL);\n\n\n")) (if signal-list (insert (mapconcat (function (lambda (x) (concat " klass->" (symbol-name x) " = " real-struct-name (symbol-name x) ";\n"))) signal-list ""))) (insert "}\n\n\n") ; We do the normal init. (insert "static void\n" prewidget "_init (" struct-name " *" widget-name")\n" "{\n \n}\n\n\n") ; And Finally, we prototype the _real_event functions. (if signal-list (insert (mapconcat (function (lambda (x) (concat "static void\n" real-struct-name (symbol-name x) " (" struct-name " *" widget-name ")\n{\n" " g_return_if_fail (" widget-name " != NULL);\n" " g_return_if_fail (" (upcase prefix) "_IS_" (upcase widget-name) " (" widget-name "));\n" " \n}\n"))) signal-list ""))) )) (defun gtk-widget-add-cplusplus-closing () (insert "#ifdef __cplusplus\n}\n#endif /* __cplusplus */\n\n\n")) (defun gtk-widget-add-preprocessor-closing (widget-name prefix) (insert "#endif /* __" (generate-allcaps-name widget-name prefix) "_H__ */\n")) (defun create-header-buffer (buffer-header license widget-name prefix inherited-widget buffer-header-name virtual signal-list) (set-buffer buffer-header) (gtk-widget-add-license license buffer-header-name) (gtk-widget-add-preprocessor widget-name prefix) (gtk-widget-add-includes widget-name prefix nil) (gtk-widget-add-cplusplus) (gtk-widget-add-macros widget-name prefix virtual) (gtk-widget-add-struct-defs widget-name prefix inherited-widget signal-list) (gtk-widget-add-header-prototypes widget-name prefix virtual) (gtk-widget-add-cplusplus-closing) (gtk-widget-add-preprocessor-closing widget-name prefix) ) (defun create-body-buffer (buffer-body license widget-name prefix inherited-widget buffer-body-name virtual signal-list) (set-buffer buffer-body) (gtk-widget-add-license license buffer-body-name) (gtk-widget-add-includes widget-name prefix 't) (gtk-widget-add-body-prototypes widget-name prefix inherited-widget signal-list) (gtk-widget-add-gtk-init widget-name prefix inherited-widget signal-list) ) ;;;###autoload (defun gtk-widget (widget-name license prefix inherited-widget virtual signal-list) "This will auto-generate a template for a generic GTK widget. You are expected to give the widget-name, license you would like the template to have, the prefix (eg. GNOME or GTK), the widget (if any) you would like to inherit from, and all the sigals. When entering the widget name, please enter it all in lower-caps, with underscores separating the pertinent parts if necessary." (interactive (list (read-string "Widget name: " nil 'widget-name) (completing-read "License: " '(("GPL" 1) ("LGPL" 2) ("NONE" 3)) nil 't "LGPL") (read-string "Is this a GNOME or GTK widget? " "GNOME") (read-string "Widget to inherit from: " "GtkObject" 'widget-in-widget) (y-or-n-p "Is the widget virtual? ") (car (read-from-string (concat "(" (read-string "Signals widget emits: " nil 'signal-list) ")"))))) (let ((buffer-header-name (concat (generate-buffer-name widget-name prefix) ".h")) (buffer-body-name (concat (generate-buffer-name widget-name prefix) ".c"))) (if (get-buffer buffer-header-name) (message "The buffer, %s exists. I cannot operate on it." buffer-header-name) (if (get-buffer buffer-body-name) (message "The buffer, %s exists. I cannot operate on it." buffer-body-name) (let ((buffer-header (get-buffer-create buffer-header-name)) (buffer-body (get-buffer-create buffer-body-name))) (create-header-buffer buffer-header license widget-name prefix inherited-widget buffer-header-name virtual signal-list) (create-body-buffer buffer-body license widget-name prefix inherited-widget buffer-body-name virtual signal-list) (switch-to-buffer buffer-body) (c-mode) (switch-to-buffer buffer-header) (c-mode)))))) ;; big 'ol hairy constants (defvar gtk-widget-author-name "J. Arthur Random") (defconst GPL-END "\n * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License as * published by the Free Software Foundation; either version 2 of the * License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * General Public License for more details. * * You should have received a copy of the GNU General Public * License along with this library; if not, write to the * Free Software Foundation, Inc., 59 Temple Place - Suite 330, * Boston, MA 02111-1307, USA. */\n") (defconst LGPL-END "\n * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Library General Public * License as published by the Free Software Foundation; either * version 2 of the License, or (at your option) any later version. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Library General Public License for more details. * * You should have received a copy of the GNU Library General Public * License along with this library; if not, write to the * Free Software Foundation, Inc., 59 Temple Place - Suite 330, * Boston, MA 02111-1307, USA. */\n")