Mercurial > hg > xemacs-beta
annotate lisp/behavior.el @ 4981:4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
-------------------- ChangeLog entries follow: --------------------
modules/ChangeLog addition:
2010-02-05 Ben Wing <ben@xemacs.org>
* postgresql/postgresql.c:
* postgresql/postgresql.c (CHECK_LIVE_CONNECTION):
* postgresql/postgresql.c (Fpq_connectdb):
* postgresql/postgresql.c (Fpq_connect_start):
* postgresql/postgresql.c (Fpq_lo_import):
* postgresql/postgresql.c (Fpq_lo_export):
* ldap/eldap.c (Fldap_open):
* ldap/eldap.c (Fldap_search_basic):
* ldap/eldap.c (Fldap_add):
* ldap/eldap.c (Fldap_modify):
* ldap/eldap.c (Fldap_delete):
* canna/canna_api.c (Fcanna_initialize):
* canna/canna_api.c (Fcanna_store_yomi):
* canna/canna_api.c (Fcanna_parse):
* canna/canna_api.c (Fcanna_henkan_begin):
EXTERNAL_TO_C_STRING returns its argument instead of storing it
in a parameter, and is renamed to EXTERNAL_TO_ITEXT. Similar
things happen to related macros. See entry in src/ChangeLog.
More Mule-izing of postgresql.c. Extract out common code
between `pq-connectdb' and `pq-connect-start'. Fix places
that signal an error string using a formatted string to instead
follow the standard and have a fixed reason followed by the
particular error message stored as one of the frobs.
src/ChangeLog addition:
2010-02-05 Ben Wing <ben@xemacs.org>
* console-msw.c (write_string_to_mswindows_debugging_output):
* console-msw.c (Fmswindows_message_box):
* console-x.c (x_perhaps_init_unseen_key_defaults):
* console.c:
* database.c (dbm_get):
* database.c (dbm_put):
* database.c (dbm_remove):
* database.c (berkdb_get):
* database.c (berkdb_put):
* database.c (berkdb_remove):
* database.c (Fopen_database):
* device-gtk.c (gtk_init_device):
* device-msw.c (msprinter_init_device_internal):
* device-msw.c (msprinter_default_printer):
* device-msw.c (msprinter_init_device):
* device-msw.c (sync_printer_with_devmode):
* device-msw.c (Fmsprinter_select_settings):
* device-x.c (sanity_check_geometry_resource):
* device-x.c (Dynarr_add_validified_lisp_string):
* device-x.c (x_init_device):
* device-x.c (Fx_put_resource):
* device-x.c (Fx_valid_keysym_name_p):
* device-x.c (Fx_set_font_path):
* dialog-msw.c (push_lisp_string_as_unicode):
* dialog-msw.c (handle_directory_dialog_box):
* dialog-msw.c (handle_file_dialog_box):
* dialog-x.c (dbox_descriptor_to_widget_value):
* editfns.c (Fformat_time_string):
* editfns.c (Fencode_time):
* editfns.c (Fset_time_zone_rule):
* emacs.c (make_argc_argv):
* emacs.c (Fdump_emacs):
* emodules.c (emodules_load):
* eval.c:
* eval.c (maybe_signal_error_1):
* event-msw.c (Fdde_alloc_advise_item):
* event-msw.c (mswindows_dde_callback):
* event-msw.c (mswindows_wnd_proc):
* fileio.c (report_error_with_errno):
* fileio.c (Fsysnetunam):
* fileio.c (Fdo_auto_save):
* font-mgr.c (extract_fcapi_string):
* font-mgr.c (Ffc_config_app_font_add_file):
* font-mgr.c (Ffc_config_app_font_add_dir):
* font-mgr.c (Ffc_config_filename):
* frame-gtk.c (gtk_set_frame_text_value):
* frame-gtk.c (gtk_create_widgets):
* frame-msw.c (mswindows_init_frame_1):
* frame-msw.c (mswindows_set_title_from_ibyte):
* frame-msw.c (msprinter_init_frame_3):
* frame-x.c (x_set_frame_text_value):
* frame-x.c (x_set_frame_properties):
* frame-x.c (start_drag_internal_1):
* frame-x.c (x_cde_transfer_callback):
* frame-x.c (x_create_widgets):
* glyphs-eimage.c (my_jpeg_output_message):
* glyphs-eimage.c (jpeg_instantiate):
* glyphs-eimage.c (gif_instantiate):
* glyphs-eimage.c (png_instantiate):
* glyphs-eimage.c (tiff_instantiate):
* glyphs-gtk.c (xbm_instantiate_1):
* glyphs-gtk.c (gtk_xbm_instantiate):
* glyphs-gtk.c (gtk_xpm_instantiate):
* glyphs-gtk.c (gtk_xface_instantiate):
* glyphs-gtk.c (cursor_font_instantiate):
* glyphs-gtk.c (gtk_redisplay_widget):
* glyphs-gtk.c (gtk_widget_instantiate_1):
* glyphs-gtk.c (gtk_add_tab_item):
* glyphs-msw.c (mswindows_xpm_instantiate):
* glyphs-msw.c (bmp_instantiate):
* glyphs-msw.c (mswindows_resource_instantiate):
* glyphs-msw.c (xbm_instantiate_1):
* glyphs-msw.c (mswindows_xbm_instantiate):
* glyphs-msw.c (mswindows_xface_instantiate):
* glyphs-msw.c (mswindows_redisplay_widget):
* glyphs-msw.c (mswindows_widget_instantiate):
* glyphs-msw.c (add_tree_item):
* glyphs-msw.c (add_tab_item):
* glyphs-msw.c (mswindows_combo_box_instantiate):
* glyphs-msw.c (mswindows_widget_query_string_geometry):
* glyphs-x.c (x_locate_pixmap_file):
* glyphs-x.c (xbm_instantiate_1):
* glyphs-x.c (x_xbm_instantiate):
* glyphs-x.c (extract_xpm_color_names):
* glyphs-x.c (x_xpm_instantiate):
* glyphs-x.c (x_xface_instantiate):
* glyphs-x.c (autodetect_instantiate):
* glyphs-x.c (safe_XLoadFont):
* glyphs-x.c (cursor_font_instantiate):
* glyphs-x.c (x_redisplay_widget):
* glyphs-x.c (Fchange_subwindow_property):
* glyphs-x.c (x_widget_instantiate):
* glyphs-x.c (x_tab_control_redisplay):
* glyphs.c (pixmap_to_lisp_data):
* gui-x.c (menu_separator_style_and_to_external):
* gui-x.c (add_accel_and_to_external):
* gui-x.c (button_item_to_widget_value):
* hpplay.c (player_error_internal):
* hpplay.c (play_sound_file):
* hpplay.c (play_sound_data):
* intl.c (Fset_current_locale):
* lisp.h:
* menubar-gtk.c (gtk_xemacs_set_accel_keys):
* menubar-msw.c (populate_menu_add_item):
* menubar-msw.c (populate_or_checksum_helper):
* menubar-x.c (menu_item_descriptor_to_widget_value_1):
* nt.c (init_user_info):
* nt.c (get_long_basename):
* nt.c (nt_get_resource):
* nt.c (init_mswindows_environment):
* nt.c (get_cached_volume_information):
* nt.c (mswindows_readdir):
* nt.c (read_unc_volume):
* nt.c (mswindows_stat):
* nt.c (mswindows_getdcwd):
* nt.c (mswindows_executable_type):
* nt.c (Fmswindows_short_file_name):
* ntplay.c (nt_play_sound_file):
* objects-gtk.c:
* objects-gtk.c (gtk_valid_color_name_p):
* objects-gtk.c (gtk_initialize_font_instance):
* objects-gtk.c (gtk_font_list):
* objects-msw.c (font_enum_callback_2):
* objects-msw.c (parse_font_spec):
* objects-x.c (x_parse_nearest_color):
* objects-x.c (x_valid_color_name_p):
* objects-x.c (x_initialize_font_instance):
* objects-x.c (x_font_instance_truename):
* objects-x.c (x_font_list):
* objects-xlike-inc.c (XFUN):
* objects-xlike-inc.c (xft_find_charset_font):
* process-nt.c (mswindows_report_winsock_error):
* process-nt.c (nt_create_process):
* process-nt.c (get_internet_address):
* process-nt.c (nt_open_network_stream):
* process-unix.c:
* process-unix.c (allocate_pty):
* process-unix.c (get_internet_address):
* process-unix.c (unix_canonicalize_host_name):
* process-unix.c (unix_open_network_stream):
* realpath.c:
* select-common.h (lisp_data_to_selection_data):
* select-gtk.c (symbol_to_gtk_atom):
* select-gtk.c (atom_to_symbol):
* select-msw.c (symbol_to_ms_cf):
* select-msw.c (mswindows_register_selection_data_type):
* select-x.c (symbol_to_x_atom):
* select-x.c (x_atom_to_symbol):
* select-x.c (hack_motif_clipboard_selection):
* select-x.c (Fx_store_cutbuffer_internal):
* sound.c (Fplay_sound_file):
* sound.c (Fplay_sound):
* sound.h (sound_perror):
* sysdep.c:
* sysdep.c (qxe_allocating_getcwd):
* sysdep.c (qxe_execve):
* sysdep.c (copy_in_passwd):
* sysdep.c (qxe_getpwnam):
* sysdep.c (qxe_ctime):
* sysdll.c (dll_open):
* sysdll.c (dll_function):
* sysdll.c (dll_variable):
* sysdll.c (search_linked_libs):
* sysdll.c (dll_error):
* sysfile.h:
* sysfile.h (PATHNAME_CONVERT_OUT_TSTR):
* sysfile.h (PATHNAME_CONVERT_OUT_UTF_8):
* sysfile.h (PATHNAME_CONVERT_OUT):
* sysfile.h (LISP_PATHNAME_CONVERT_OUT):
* syswindows.h (ITEXT_TO_TSTR):
* syswindows.h (LOCAL_FILE_FORMAT_TO_TSTR):
* syswindows.h (TSTR_TO_LOCAL_FILE_FORMAT):
* syswindows.h (LOCAL_FILE_FORMAT_TO_INTERNAL_MSWIN):
* syswindows.h (LISP_LOCAL_FILE_FORMAT_MAYBE_URL_TO_TSTR):
* text.h:
* text.h (eicpy_ext_len):
* text.h (enum new_dfc_src_type):
* text.h (EXTERNAL_TO_ITEXT):
* text.h (GET_STRERROR):
* tooltalk.c (check_status):
* tooltalk.c (Fadd_tooltalk_message_arg):
* tooltalk.c (Fadd_tooltalk_pattern_attribute):
* tooltalk.c (Fadd_tooltalk_pattern_arg):
* win32.c (tstr_to_local_file_format):
* win32.c (mswindows_lisp_error_1):
* win32.c (mswindows_report_process_error):
* win32.c (Fmswindows_shell_execute):
* win32.c (mswindows_read_link_1):
Changes involving external/internal format conversion,
mostly code cleanup and renaming.
1. Eliminate the previous macros like LISP_STRING_TO_EXTERNAL
that stored its result in a parameter. The new version of
LISP_STRING_TO_EXTERNAL returns its result through the
return value, same as the previous NEW_LISP_STRING_TO_EXTERNAL.
Use the new-style macros throughout the code.
2. Rename C_STRING_TO_EXTERNAL and friends to ITEXT_TO_EXTERNAL,
in keeping with overall naming rationalization involving
Itext and related types.
Macros involved in previous two:
EXTERNAL_TO_C_STRING -> EXTERNAL_TO_ITEXT
EXTERNAL_TO_C_STRING_MALLOC -> EXTERNAL_TO_ITEXT_MALLOC
SIZED_EXTERNAL_TO_C_STRING -> SIZED_EXTERNAL_TO_ITEXT
SIZED_EXTERNAL_TO_C_STRING_MALLOC -> SIZED_EXTERNAL_TO_ITEXT_MALLOC
C_STRING_TO_EXTERNAL -> ITEXT_TO_EXTERNAL
C_STRING_TO_EXTERNAL_MALLOC -> ITEXT_TO_EXTERNAL_MALLOC
LISP_STRING_TO_EXTERNAL
LISP_STRING_TO_EXTERNAL_MALLOC
LISP_STRING_TO_TSTR
C_STRING_TO_TSTR -> ITEXT_TO_TSTR
TSTR_TO_C_STRING -> TSTR_TO_ITEXT
The following four still return their values through parameters,
since they have more than one value to return:
C_STRING_TO_SIZED_EXTERNAL -> ITEXT_TO_SIZED_EXTERNAL
LISP_STRING_TO_SIZED_EXTERNAL
C_STRING_TO_SIZED_EXTERNAL_MALLOC -> ITEXT_TO_SIZED_EXTERNAL_MALLOC
LISP_STRING_TO_SIZED_EXTERNAL_MALLOC
Sometimes additional casts had to be inserted, since the old
macros played strange games and completely defeated the type system
of the store params.
3. Rewrite many places where direct calls to TO_EXTERNAL_FORMAT
occurred with calls to one of the convenience macros listed above,
or to make_extstring().
4. Eliminate SIZED_C_STRING macros (they were hardly used, anyway)
and use a direct call to TO_EXTERNAL_FORMAT or TO_INTERNAL_FORMAT.
4. Use LISP_PATHNAME_CONVERT_OUT in many places instead of something
like LISP_STRING_TO_EXTERNAL(..., Qfile_name).
5. Eliminate some temporary variables that are no longer necessary
now that we return a value rather than storing it into a variable.
6. Some Mule-izing in database.c.
7. Error functions:
-- A bit of code cleanup in maybe_signal_error_1.
-- Eliminate report_file_type_error; it's just an alias for
signal_error_2 with params in a different order.
-- Fix some places in the hostname-handling code that directly
inserted externally-retrieved error strings into the
supposed ASCII "reason" param instead of doing the right thing
and sticking text descriptive of what was going on in "reason"
and putting the external message in a frob.
8. Use Ascbyte instead of CIbyte in process-unix.c and maybe one
or two other places.
9. Some code cleanup in copy_in_passwd() in sysdep.c.
10. Fix a real bug due to accidental variable shadowing in
tstr_to_local_file_format() in win32.c.
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Fri, 05 Feb 2010 11:02:24 -0600 |
| parents | ebb35ddea76a |
| children | 2def0d83a5e3 |
| rev | line source |
|---|---|
| 2546 | 1 ;;; behavior.el --- consistent interface onto packages |
| 502 | 2 |
| 2546 | 3 ;; Copyright (C) 2000, 2001, 2002, 2003 Ben Wing. |
| 502 | 4 |
| 5 ;; Author: Ben Wing | |
| 6 ;; Maintainer: XEmacs Development Team | |
| 7 ;; Keywords: internal, dumped | |
| 8 | |
| 9 ;; This file is part of XEmacs. | |
| 10 | |
| 11 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 12 ;; under the terms of the GNU General Public License as published by | |
| 13 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 14 ;; any later version. | |
| 15 | |
| 16 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 19 ;; General Public License for more details. | |
| 20 | |
| 21 ;; You should have received a copy of the GNU General Public License | |
| 22 ;; along with XEmacs; see the file COPYING. If not, write to the | |
| 23 ;; Free Software Foundation, 59 Temple Place - Suite 330, | |
| 24 ;; Boston, MA 02111-1307, USA. | |
| 25 | |
| 26 ;;; Synched up with: Not in FSF. | |
| 27 | |
| 28 ;;; Authorship: | |
| 29 | |
| 30 ;; Created July 2000 by Ben Wing. | |
| 31 | |
| 32 ;;; Commentary: | |
| 33 | |
| 2546 | 34 ;; This file is dumped with XEmacs. |
| 35 | |
| 36 ;; This file is part of the "Behaviors" project and is a work in progress. | |
| 37 ;; The purpose of the project is to provide (a) a consistent interface (at | |
| 38 ;; the API level) onto the functionality provided by packages, and (b) an | |
| 39 ;; easy-to-use user interface for this functionality, something that | |
| 40 ;; *really works*. | |
| 41 ;; | |
| 42 ;; First, what characteristics do/should packages have? (NOTE: In this | |
| 43 ;; discussion below, `package' and `behavior' are being used more or less | |
| 44 ;; interchangeably. Eventually this will get resolved.) | |
| 45 | |
| 46 ;; 1) A file, or one or more file, containing the code of the package. In | |
| 47 ;; addition, a "head" file in the case that the package needs to be | |
| 48 ;; loaded in order to get its functionality (e.g. "load-to-enable" | |
| 49 ;; packages -- an abomination that is tolerated only with severe | |
| 50 ;; displeasure). | |
| 51 ;; 2) A Lisp name -- a fairly short symbol (2-3 words max), uncapitalized, | |
| 52 ;; without use of excessive abbreviation and with words set off by | |
| 53 ;; dashes. This should be the same as the name of the topmost custom | |
| 54 ;; group associated with the package (see next item), and preferably the | |
| 55 ;; same as the common prefix used for variables defined by your package | |
| 56 ;; and the name of the head file of the package. | |
| 57 ;; 3) Associated custom group listing the settings associated with the package. | |
| 58 ;; 4) Enable and disable methods for turning on or off the functionality of | |
| 59 ;; the package, if it's amenable to such a model. Most packages are of two | |
| 60 ;; types: | |
| 61 ;; | |
| 62 ;; (a) They add some functionality to XEmacs, which is incorporated | |
| 63 ;; into and makes changes to the normal functionality of XEmacs. Once the | |
| 64 ;; package is enabled, the user doesn't have to do anything specific for | |
| 65 ;; the package to do its thing -- it happens automatically if the user is | |
| 66 ;; using the area whose behavior has been changed. These include packages | |
| 67 ;; such as `avoid' (which makes the mouse poointer move when the cursor | |
| 68 ;; gets too close), EFS (which adds the ability to treat an FTP site as | |
| 69 ;; part of the local file system), the packages that supply the | |
| 70 ;; mode-specific handling for various files, etc | |
| 71 ;; | |
| 72 ;; (b) They provide functionality in the form of specific command to be | |
| 73 ;; invoked. This can be as simple as the `hippie-expand' command (tries | |
| 74 ;; lots of different expansion methods for the text before point, to | |
| 75 ;; try and get a result) and as complicated as GNUS or VM. | |
| 76 ;; | |
| 77 ;; Some packages might provide both -- you can enable them and they | |
| 78 ;; incorporate some functionality into the XEmacs base, but while | |
| 79 ;; they're enabled they provide certain commands. #### We need some | |
| 80 ;; thought here, and case-by-case analysis, to determine if this really | |
| 81 ;; makes sense -- can the enable/disable be removed and whatever needs | |
| 82 ;; to happen incorporated as part of the command? can the | |
| 83 ;; enable/disable just added to the commands? | |
| 84 ;; | |
| 85 ;; 5) Packages of type (b) just above will have a list of commands that can be | |
| 86 ;; run. They should be in standard menubar format -- i.e. just like a | |
| 87 ;; submenu, but without the initial string indidicating the name of the | |
| 88 ;; menu. | |
| 89 ;; 6) Short doc string, for use in a menu item. *NOT* necessarily the same | |
| 90 ;; as the documentation for the Custom group, which is often too long. | |
| 91 ;; 7) Long documentation. | |
| 92 ;; | |
| 93 ;; Good package etiquette: | |
| 94 ;; | |
| 95 ;; | |
| 96 ;; -- Never mess with the menu yourself, or try to "cheat" by putting yourself | |
| 97 ;; high up in the hierarchy, e.g. at the top-level or directly off a | |
| 98 ;; top-level group that expects to contain only groups of groups, not | |
| 99 ;; end-level groups. | |
| 100 ;; | |
| 101 ;; -- Never use the `override-behavior' commands or the like for specifying | |
| 102 ;; (in an overriding fashion) the exact appearance of the hierarchies. | |
| 103 ;; | |
| 104 ;; -- For type (a), with enable/disable methods: | |
| 105 ;; | |
| 106 ;; (a) Loading the file should NOT DO ANYTHING. Not enable, not add hooks, | |
| 107 ;; nothing. | |
| 108 ;; (b) Both enable and disable hooks must exist. The disable hook must | |
| 109 ;; completely reset the environment to how it was before the package | |
| 110 ;; was enabled. This includes restoring the prior bindings for | |
| 111 ;; modified key bindings. #### We need some helper function to assist | |
| 112 ;; with remembering the old key bindings and putting them back only | |
| 113 ;; when new key bindings haven't been made -- but recognize when those | |
| 114 ;; new key bondings were attached as a result of loading another | |
| 115 ;; package, so that after any order of loading and unloading a series | |
| 116 ;; of packages, the original bindings will eventually occur. (Something | |
| 117 ;; like `advice' for key definitions.) Replacement of functions should | |
| 118 ;; happen through `advice'. | |
| 119 ;; | |
| 120 ;; We recognize that many packages out there don't follow these precepts at | |
| 121 ;; all. Many or most of them are install-only, often happening | |
| 122 ;; automatically when the file is loaded. Converting these will be a step | |
| 123 ;; at a time: First, redo the latter type so that the initialization code | |
| 124 ;; is put into a function and not run automatically upon load. Next step, | |
| 125 ;; try to provide some sort of disable. Third step, work on making sure | |
| 126 ;; that disable removes *everything* and enable puts it all back. Fourth | |
| 127 ;; step, work on properly advising keys and functions. | |
| 128 ;; | |
| 129 | |
| 130 ;; Comparison/Integration with Custom: | |
| 131 | |
| 132 ;; Custom only handles variable settings, and has no concept of standard | |
| 133 ;; enable/disable methods for a package, a standard way of specifying | |
| 134 ;; package documentation, or a list of commands associated with a package. | |
| 135 ;; Also, its groups do not always map very well onto packages and the | |
| 136 ;; resulting hierarchy is too big, confusing, difficult-to-navigate, and | |
| 137 ;; incoherent. More generally it does not address at all the basic problem | |
| 138 ;; that a hierarchy created in a decentralized fashion -- and by a large | |
| 139 ;; number of authors, some more competent than others -- will inevitably be | |
| 140 ;; incoherent when put together. | |
| 141 ;; | |
| 142 | |
| 143 ;; In general, ease-of-use was not the overarching goal of Custom. The | |
| 144 ;; primary goal of Custom seems to have been to provide a consistent interface | |
| 145 ;; and get all the packages to use it. Ease-of-use -- or even following | |
| 146 ;; established user-interface standards -- has taken a far-distant second, and | |
| 147 ;; appears in many respects to be an afterthought that never had any serious | |
| 148 ;; effort investigated into it. | |
| 149 ;; | |
| 150 ;; The eventual intent of this project is to integrate with custom. The final | |
| 151 ;; intent of integration is that this project subsumes Custom completely, | |
| 152 ;; making Custom the unified, user-friendly means of controlling XEmacs that | |
| 153 ;; has never properly existed. However, that will take a lot of work. For | |
| 154 ;; the meantime, the plan is to develop the Behavior subsystem independent of | |
| 155 ;; Custom, with ease-of-use as the primary goal, and get it to the point where | |
| 156 ;; it encompasses most packages out there, has stabilized its interface, and | |
| 157 ;; works well. At that point, we will consider integration with Custom. (Note | |
| 158 ;; that the hard part of the Behavior work is not actually behaviorizing the | |
| 159 ;; packages, but developing the interface itself.) | |
| 160 ;; | |
| 161 ;; As for integrating with Custom -- ideally that would mean simply extending | |
| 162 ;; defgroup, but that is not really possible given that backward-compatibility | |
| 163 ;; would not work -- existing versions of `defgroup' give an error when | |
| 164 ;; presented with an unknown keyword. In practice, then, this might mean that | |
| 165 ;; a separate `define-behavior' command (or `defpackage', or the like) will | |
| 166 ;; still exist. | |
| 502 | 167 |
| 168 ;;; Code: | |
| 169 | |
| 800 | 170 ;; Hash table mapping behavior names to property lists, with entries for |
| 2546 | 171 ;; :group, :custom-group, :short-doc, :require, :enable, :disable, |
| 172 ;; and :commands. | |
| 800 | 173 (defconst behavior-hash-table (make-hash-table)) |
| 2546 | 174 ;; Hash table mapping groups to property lists (entries for :group, :children, |
| 175 ;; :short-doc). | |
| 176 (defconst behavior-group-hash-table (make-hash-table)) | |
| 177 ;; Hash table with override information for groups. | |
| 178 ;; :short-doc). | |
| 179 (defconst behavior-override-hash-table (make-hash-table)) | |
| 800 | 180 |
| 181 (defvar within-behavior-enabling-disabling nil) | |
| 182 | |
| 183 (defgroup behaviors nil | |
| 184 "Behaviors -- high-level functionality interface.") | |
| 185 | |
| 186 ;; List of enabled behaviors. | |
| 187 (defcustom enabled-behavior-list nil | |
| 188 "List of currently enabled behaviors. | |
| 189 Normally, don't set it directly; use `enable-behavior' or `disable-behavior'." | |
| 190 :initialize #'set-default | |
| 191 :set #'(lambda (sym val) | |
| 192 (if within-behavior-enabling-disabling | |
| 193 (set sym val) | |
| 194 (let* ((old-val enabled-behavior-list) | |
| 195 (disable-list (set-difference old-val val)) | |
| 196 (enable-list (set-difference val old-val))) | |
| 197 (dolist (b disable-list) | |
| 198 (disable-behavior b t)) | |
| 199 (dolist (b enable-list) | |
| 200 (enable-behavior b t)) | |
| 897 | 201 (assert (equal (sort (copy-sequence enabled-behavior-list) 'string-lessp) |
| 202 (sort (copy-sequence val) 'string-lessp)))))) | |
| 800 | 203 :type '(repeat (symbol :tag "Behavior")) |
| 204 :group 'behaviors) | |
| 205 | |
| 502 | 206 |
| 207 (defvar behavior-history nil | |
| 208 "History of entered behaviors.") | |
| 209 | |
| 2546 | 210 (defun behavior-group-p (group) |
| 211 "Non-nil if GROUP is the name of a valid behavior group." | |
| 212 (not (null (gethash group behavior-group-hash-table)))) | |
| 213 | |
| 214 (defun check-behavior-group (group) | |
| 215 "Verify that GROUP is a valid behavior group, or nil. | |
| 216 Return GROUP if so." | |
| 217 (or (behavior-group-p group) | |
| 218 (error 'invalid-argument "Invalid behavior group" group)) | |
| 219 group) | |
| 220 | |
| 221 (defun* define-behavior (name doc-string &key | |
| 222 group custom-group | |
| 223 (short-doc | |
| 224 (capitalize-string-as-title | |
| 225 (replace-in-string (symbol-name name) "-" " "))) | |
| 226 require enable disable commands | |
| 227 &allow-other-keys) | |
| 228 ;; We allow other keys to allow for the possibility of extensions by | |
| 229 ;; later versions of XEmacs. Packages should be able to support those | |
| 230 ;; extensions without worrying about causing problems with older versions | |
| 231 ;; of XEmacs. | |
| 502 | 232 "Define a behavior named NAME. |
| 233 DOC-STRING must be specified, a description of what the behavior does | |
| 234 when it's enabled and how to further control it (typically through | |
| 235 custom variables). Accepted keywords are | |
| 236 | |
| 2546 | 237 :group Symbol naming the behavior group this behavior is within. |
| 238 :custom-group Symbol naming the custom group containing the options that | |
| 239 can be set in association with this behavior. If not specified, | |
| 240 the custom group with the same name as the behavior will be | |
| 241 used, if it exists. | |
| 800 | 242 :short-doc A \"pretty\" version of the name, for use in menus. If omitted |
| 243 a prettified name will be generated. | |
| 244 :require A single symbol or a list of such symbols, which need to be | |
| 245 present at enable time, or will be loaded using `require'. | |
| 246 :enable A function of no variables, which turns the behavior on. | |
| 247 :disable A function of no variables, which turns the behavior off. | |
| 2546 | 248 :commands A list of interactive commands that can be invoked in |
| 249 conjunction with the behavior. These will appear in a submenu | |
| 250 along with the rest of the items for the behavior. | |
| 502 | 251 |
| 252 Behaviors are assumed to be global, and to take effect immediately; if | |
| 253 the underlying package is per-buffer, it may have to scan all existing | |
| 254 buffers and frob them. When a behavior is disabled, it should completely | |
| 255 go away *everywhere*, as if it were never invoked at all. | |
| 256 | |
| 2546 | 257 The :disable keyword can be missing, although this is considered bad |
| 502 | 258 practice. In such a case, attempting to disable the behavior will signal |
| 2546 | 259 an error unless you use the `force' option. |
| 260 | |
| 261 The :enable keyword can be missing. This is useful for behaviors that | |
| 262 are really a series of related commands without anything semantically | |
| 263 corresponding to \"turning on\" or \"turning off\" the behavior. | |
| 264 | |
| 265 A behavior with no :enable and no :command is possible. This might be | |
| 266 used, for example, by a behavior that encapsulates a series of related | |
| 267 Lisp functions. Such behaviors may be handled specially, e.g. not | |
| 268 displayed in the menus or displayed in a separate location, since they | |
| 269 have no user-invocable behavior." | |
| 270 (let ((entry (list :group (check-behavior-group group) | |
| 271 :custom-group custom-group | |
| 272 :short-doc short-doc :require require | |
| 273 :enable enable :disable disable | |
| 274 :commands commands))) | |
| 275 (puthash name entry behavior-hash-table)) | |
| 276 ;; update the children list of the group we're in (maybe nil). | |
| 277 (unless (member name (getf (gethash group behavior-group-hash-table) | |
| 278 :children)) | |
| 279 (push name (getf (gethash group behavior-group-hash-table) :children)))) | |
| 280 | |
| 281 (defun* override-behavior (name &key | |
| 282 short-doc | |
| 283 group | |
| 284 include | |
| 285 demote-others) | |
| 286 "Override the default properties of a behavior group NAME. | |
| 287 Normally, groups are created and assigned properties by individual packages. | |
| 288 The resulting hierarchy may not make much sense globally. This function | |
| 289 allows the hierarchy and appearance of a group to be specified globally, | |
| 290 and will take precendence over the properties assigned by `define-behavior-group'. This allows a global organization to be imposed on groups, while still allowing for graceful handling of new or unknown groups. | |
| 291 | |
| 292 NAME can be a symbol specifying a group name, or a list of | |
| 293 \(PARENT [...] NAME), where a path from a particular parent is explicitly | |
| 294 given. (This latter form allows the same name to be assigned to more than one | |
| 295 group.) | |
| 296 | |
| 297 Accepted keywords are | |
| 298 | |
| 299 :short-doc A \"pretty\" version of the name, for use in menus. | |
| 300 :group Parent group, if any. Should not be given if the parents are | |
| 301 explicitly specified in NAME. | |
| 302 :include A list of behaviors that are specifically included in this | |
| 303 group, in addition to those that are included by the behaviors | |
| 304 themselves. | |
| 305 :demote-others If non-nil, exclude all behaviors not specified in the :include | |
| 306 list and put them instead (i.e. \"demote\" them) to another group, | |
| 307 usually a subgroup." | |
| 308 (let ((entry (list :group (check-behavior-group group) | |
| 309 :short-doc short-doc | |
| 310 :include include | |
| 311 :demote-others demote-others))) | |
| 312 (puthash name entry behavior-override-hash-table))) | |
| 313 | |
| 314 (defun* define-behavior-group (name &key | |
| 315 (short-doc | |
| 316 (capitalize-string-as-title | |
| 317 (replace-in-string (symbol-name name) "-" | |
| 318 " "))) | |
| 319 group) | |
| 320 "Define a behavior group NAME. | |
| 321 | |
| 322 NAME can be a symbol specifying a group name, or a list of | |
| 323 \(PARENT [...] NAME), where a path from a particular parent is explicitly | |
| 324 given. (This latter form allows the same name to be assigned to more than one | |
| 325 group.) | |
| 326 | |
| 327 Accepted keywords are | |
| 328 | |
| 329 :short-doc A \"pretty\" version of the name, for use in menus. If omitted | |
| 330 a prettified name will be generated. | |
| 331 :group Parent group, if any. Should not be given if the parents are | |
| 332 explicitly specified in NAME." | |
| 333 (let ((entry (list :group (check-behavior-group group) | |
| 334 :short-doc short-doc))) | |
| 335 (puthash name entry behavior-group-hash-table)) | |
| 336 ;; update the children list of the parent (maybe nil). | |
| 337 (push name (getf (gethash group behavior-group-hash-table) :children))) | |
| 502 | 338 |
| 339 (defun read-behavior (prompt &optional must-match initial-contents history | |
| 2546 | 340 default-value) |
| 502 | 341 "Return a behavior symbol from the minibuffer, prompting with string PROMPT. |
| 342 If non-nil, optional second arg INITIAL-CONTENTS is a string to insert | |
| 343 in the minibuffer before reading. | |
| 344 Third arg HISTORY, if non-nil, specifies a history list. (It defaults to | |
| 345 `behavior-history'.) | |
| 346 Fourth arg DEFAULT-VALUE is the default value. If non-nil, it is used | |
| 347 for history command, and as the value to return if the user enters the | |
| 348 empty string." | |
| 349 (let ((result | |
| 350 (completing-read | |
| 351 prompt | |
| 352 (let ((table (let (lis) | |
| 353 (maphash #'(lambda (key val) | |
| 354 (push (cons key val) lis)) | |
| 355 behavior-hash-table) | |
| 356 (nreverse lis)))) | |
| 357 (mapc #'(lambda (aentry) | |
| 2546 | 358 (setcar aentry (symbol-name (car aentry)))) |
| 502 | 359 table) |
| 360 table) | |
| 2546 | 361 nil must-match initial-contents (or history 'behavior-history) |
| 502 | 362 default-value))) |
| 363 (if (and result (stringp result)) | |
| 364 (intern result) | |
| 365 result))) | |
| 366 | |
| 800 | 367 (defun behavior-enabled-p (behavior) |
| 368 "Non-nil if BEHAVIOR (a symbol) if currently enabled." | |
| 369 (memq behavior enabled-behavior-list)) | |
| 502 | 370 |
| 371 (defun enable-behavior (behavior &optional force) | |
| 372 "Enable the specified behavior." | |
| 373 (interactive (list (read-behavior "Enable Behavior: " t) current-prefix-arg)) | |
| 374 (let ((plist (gethash behavior behavior-hash-table))) | |
| 375 (or plist (error 'invalid-argument "Not a behavior" behavior)) | |
| 800 | 376 (or force (not (memq behavior enabled-behavior-list)) |
| 377 (error 'invalid-change "Behavior already enabled" behavior)) | |
| 502 | 378 (let ((require (getf plist :require)) |
| 379 (enable (getf plist :enable))) | |
| 380 (cond ((listp require) | |
| 381 (mapc #'(lambda (sym) (require sym)) require)) | |
| 382 ((symbolp require) | |
| 383 (require require)) | |
| 384 ((null require)) | |
| 385 (t (error 'invalid-argument "Invalid :require spec" require))) | |
| 800 | 386 (message "Enabling behavior %s..." behavior) |
| 387 (if enable (funcall enable)) | |
| 388 (message "Enabling behavior %s...done" behavior) | |
| 389 (let ((within-behavior-enabling-disabling t)) | |
| 390 (customize-set-variable 'enabled-behavior-list | |
| 391 (cons behavior enabled-behavior-list)))))) | |
| 502 | 392 |
| 393 (defun disable-behavior (behavior &optional force) | |
| 394 "Disable the specified behavior." | |
| 395 (interactive (list (read-behavior "Disable Behavior: " t) | |
| 396 current-prefix-arg)) | |
| 397 (let ((plist (gethash behavior behavior-hash-table))) | |
| 398 (or plist (error 'invalid-argument "Not a behavior" behavior)) | |
| 800 | 399 (or force (memq behavior enabled-behavior-list) |
| 400 (error 'invalid-change "Behavior not enabled" behavior)) | |
| 502 | 401 (let ((require (getf plist :require)) |
| 402 (disable (getf plist :disable))) | |
| 403 (cond ((listp require) | |
| 404 (mapc #'(lambda (sym) (require sym)) require)) | |
| 405 ((symbolp require) | |
| 406 (require require)) | |
| 407 ((null require)) | |
| 408 (t (error 'invalid-argument "Invalid :require spec" require))) | |
| 800 | 409 (message "Disabling behavior %s..." behavior) |
| 410 (if disable (funcall disable)) | |
| 411 (message "Disabling behavior %s...done" behavior) | |
| 412 (let ((within-behavior-enabling-disabling t)) | |
| 413 (customize-set-variable 'enabled-behavior-list | |
| 414 (delq behavior enabled-behavior-list)))))) | |
| 502 | 415 |
| 2546 | 416 (defun compute-behavior-group-children (group hash) |
| 417 "Compute the actual children for GROUP and its subgroups. | |
| 418 This takes into account the override information specified." | |
| 419 (let* ((group-plist (gethash group behavior-group-hash-table)) | |
| 420 (override (gethash group behavior-override-hash-table)) | |
| 421 (children (getf group-plist :children))) | |
| 422 ) | |
| 423 ) | |
| 424 | |
| 425 (defun behavior-menu-filter-1 (menu group) | |
| 426 (submenu-generate-accelerator-spec | |
| 427 (let* ( | |
| 428 ;;options | |
| 429 ;;help | |
| 430 (enable | |
| 431 (menu-split-long-menu | |
| 432 (menu-sort-menu | |
| 433 (let ((group-plist (gethash group behavior-group-hash-table))) | |
| 434 (loop for behavior in (getf group-plist :children) | |
| 435 nconc (if (behavior-group-p behavior) | |
| 436 (list | |
| 437 (cons (getf | |
| 438 (gethash behavior behavior-group-hash-table) | |
| 439 :short-doc) | |
| 440 (behavior-menu-filter-1 menu behavior))) | |
| 441 (let* ((plist (gethash behavior behavior-hash-table)) | |
| 442 (commands (getf plist :commands))) | |
| 443 (nconc | |
| 444 (if (getf plist :enable) | |
| 445 `([,(format "%s (%s) [toggle]" | |
| 446 (getf plist :short-doc) | |
| 447 behavior) | |
| 448 (if (memq ',behavior | |
| 449 enabled-behavior-list) | |
| 450 (disable-behavior ',behavior) | |
| 451 (enable-behavior ',behavior)) | |
| 452 :active ,(if (getf plist :disable) t | |
| 453 (not (memq | |
| 454 ',behavior | |
| 455 enabled-behavior-list))) | |
| 456 :style toggle | |
| 457 :selected (memq ',behavior | |
| 458 enabled-behavior-list)])) | |
| 459 (cond ((null commands) nil) | |
| 460 ((and (eq (length commands) 1) | |
| 461 (vectorp (elt commands 0))) | |
| 462 (let ((comm (copy-sequence | |
| 463 (elt commands 0)))) | |
| 464 (setf (elt comm 0) | |
| 465 (format "%s (%s)" | |
| 466 (elt comm 0) behavior)) | |
| 467 (list comm))) | |
| 468 (t (list | |
| 469 (cons (format "%s (%s) Commands" | |
| 470 (getf plist :short-doc) | |
| 471 behavior) | |
| 472 commands))))))))) | |
| 473 )) | |
| 474 ) | |
| 475 ) | |
| 476 enable) | |
| 477 '(?p))) | |
| 478 | |
| 479 (defun behavior-menu-filter (menu) | |
| 480 (append | |
|
4372
ebb35ddea76a
Byte-compile menu lambdas; make the menu of available tutorials more readable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2546
diff
changeset
|
481 `(("%_Package Utilities" |
| 2546 | 482 ("%_Set Download Site" |
| 483 ("%_Official Releases" | |
|
4372
ebb35ddea76a
Byte-compile menu lambdas; make the menu of available tutorials more readable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2546
diff
changeset
|
484 :filter ,#'(lambda (&rest junk) |
|
ebb35ddea76a
Byte-compile menu lambdas; make the menu of available tutorials more readable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2546
diff
changeset
|
485 (menu-split-long-menu |
|
ebb35ddea76a
Byte-compile menu lambdas; make the menu of available tutorials more readable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2546
diff
changeset
|
486 (submenu-generate-accelerator-spec |
|
ebb35ddea76a
Byte-compile menu lambdas; make the menu of available tutorials more readable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2546
diff
changeset
|
487 (package-ui-download-menu))))) |
| 2546 | 488 ("%_Pre-Releases" |
|
4372
ebb35ddea76a
Byte-compile menu lambdas; make the menu of available tutorials more readable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2546
diff
changeset
|
489 :filter ,#'(lambda (&rest junk) |
|
ebb35ddea76a
Byte-compile menu lambdas; make the menu of available tutorials more readable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2546
diff
changeset
|
490 (menu-split-long-menu |
|
ebb35ddea76a
Byte-compile menu lambdas; make the menu of available tutorials more readable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2546
diff
changeset
|
491 (submenu-generate-accelerator-spec |
|
ebb35ddea76a
Byte-compile menu lambdas; make the menu of available tutorials more readable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2546
diff
changeset
|
492 (package-ui-pre-release-download-menu))))) |
| 2546 | 493 ("%_Site Releases" |
|
4372
ebb35ddea76a
Byte-compile menu lambdas; make the menu of available tutorials more readable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2546
diff
changeset
|
494 :filter ,#'(lambda (&rest junk) |
|
ebb35ddea76a
Byte-compile menu lambdas; make the menu of available tutorials more readable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2546
diff
changeset
|
495 (menu-split-long-menu |
|
ebb35ddea76a
Byte-compile menu lambdas; make the menu of available tutorials more readable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2546
diff
changeset
|
496 (submenu-generate-accelerator-spec |
|
ebb35ddea76a
Byte-compile menu lambdas; make the menu of available tutorials more readable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2546
diff
changeset
|
497 (package-ui-site-release-download-menu)))))) |
| 2546 | 498 "--:shadowEtchedIn" |
| 499 ["%_Update Package Index" package-get-update-base] | |
| 500 ["%_List and Install" pui-list-packages] | |
| 501 ["U%_pdate Installed Packages" package-get-update-all] | |
| 502 ["%_Help" (Info-goto-node "(xemacs)Packages")]) | |
| 503 "----") | |
| 504 (behavior-menu-filter-1 menu nil))) | |
| 505 | |
| 506 ;; Initialize top-level group. | |
| 507 (puthash nil '(:children nil :short-doc "Root") behavior-group-hash-table) | |
| 508 | |
| 502 | 509 (provide 'behavior) |
| 510 | |
| 511 ;;; finder-inf.el ends here |