annotate lisp/itimer.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 d8c340c9adb6
children 91b3aa59f49b
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
613
023b83f4e54b [xemacs-hg @ 2001-06-10 10:42:16 by ben]
ben
parents: 446
diff changeset
1 ;;; Interval timers for XEmacs
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2 ;;; Copyright (C) 1988, 1991, 1993, 1997, 1998 Kyle E. Jones
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3 ;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4 ;;; This program is free software; you can redistribute it and/or modify
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5 ;;; it under the terms of the GNU General Public License as published by
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6 ;;; the Free Software Foundation; either version 2, or (at your option)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
7 ;;; any later version.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
8 ;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
9 ;;; This program is distributed in the hope that it will be useful,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
12 ;;; GNU General Public License for more details.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
13 ;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
14 ;;; A copy of the GNU General Public License can be obtained from this
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
15 ;;; program's author (send electronic mail to kyle@uunet.uu.net) or from
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
16 ;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
17 ;;; 02139, USA.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
18 ;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
19 ;;; Send bug reports to kyle_jones@wonderworks.com
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
20
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
21 (provide 'itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
22
430
a5df635868b2 Import from CVS: tag r21-2-23
cvs
parents: 428
diff changeset
23 (require 'lisp-float-type)
a5df635868b2 Import from CVS: tag r21-2-23
cvs
parents: 428
diff changeset
24
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
25 ;; `itimer' feature means Emacs-Lisp programmers get:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
26 ;; itimerp
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
27 ;; itimer-live-p
2285
914c5afaac33 [xemacs-hg @ 2004-09-20 19:11:29 by james]
james
parents: 2284
diff changeset
28 ;; itimer-name
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
29 ;; itimer-value
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
30 ;; itimer-restart
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
31 ;; itimer-function
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
32 ;; itimer-uses-arguments
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
33 ;; itimer-function-arguments
2285
914c5afaac33 [xemacs-hg @ 2004-09-20 19:11:29 by james]
james
parents: 2284
diff changeset
34 ;; set-itimer-name
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
35 ;; set-itimer-value
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
36 ;; set-itimer-restart
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
37 ;; set-itimer-function
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
38 ;; set-itimer-uses-arguments
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
39 ;; set-itimer-function-arguments
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
40 ;; get-itimer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
41 ;; start-itimer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
42 ;; read-itimer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
43 ;; delete-itimer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
44 ;; activate-itimer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
45 ;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
46 ;; Interactive users get these commands:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
47 ;; edit-itimers
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
48 ;; list-itimers
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
49 ;; start-itimer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
50 ;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
51 ;; See the doc strings of these functions for more information.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
52
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 430
diff changeset
53 (defvar itimer-version "1.09"
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
54 "Version number of the itimer package.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
55
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
56 (defvar itimer-list nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
57 "List of all active itimers.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
58
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
59 (defvar itimer-process nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
60 "Process that drives all itimers, if a subprocess is being used.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
61
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
62 (defvar itimer-timer nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
63 "Emacs internal timer that drives the itimer system, if a subprocess
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
64 is not being used to drive the system.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
65
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
66 (defvar itimer-timer-last-wakeup nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
67 "The time the timer driver function last ran.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
68
430
a5df635868b2 Import from CVS: tag r21-2-23
cvs
parents: 428
diff changeset
69 (defvar itimer-short-interval 1e-3
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
70 "Interval used for scheduling an event a very short time in the future.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
71 Used internally to make the scheduler wake up early.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
72 Unit is seconds.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
73
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
74 ;; This value is maintained internally; it does not determine
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
75 ;; itimer granularity. Itimer granularity is 1 second if your
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
76 ;; Emacs doesn't support floats or your system doesn't have a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
77 ;; clock with microsecond granularity. Otherwise granularity is
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
78 ;; to the microsecond, although you can't possibly get timers to be
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
79 ;; executed with this kind of accuracy in practice. There will
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
80 ;; be delays due to system and Emacs internal activity that delay
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
81 ;; dealing with synchronous events and process output.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
82 (defvar itimer-next-wakeup itimer-short-interval
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
83 "Itimer process will wakeup to service running itimers within this
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
84 many seconds.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
85
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
86 (defvar itimer-edit-map nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
87 "Keymap used when in Itimer Edit mode.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
88
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
89 (if itimer-edit-map
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
90 ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
91 (setq itimer-edit-map (make-sparse-keymap))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
92 (define-key itimer-edit-map "s" 'itimer-edit-set-field)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
93 (define-key itimer-edit-map "d" 'itimer-edit-delete-itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
94 (define-key itimer-edit-map "q" 'itimer-edit-quit)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
95 (define-key itimer-edit-map "\t" 'itimer-edit-next-field)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
96 (define-key itimer-edit-map " " 'next-line)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
97 (define-key itimer-edit-map "n" 'next-line)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
98 (define-key itimer-edit-map "p" 'previous-line)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
99 (define-key itimer-edit-map "\C-?" 'itimer-edit-previous-field)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
100 (define-key itimer-edit-map "x" 'start-itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
101 (define-key itimer-edit-map "?" 'itimer-edit-help))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
102
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
103 (defvar itimer-inside-driver nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
104
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
105 (defvar itimer-edit-start-marker nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
106
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
107 ;; macros must come first... or byte-compile'd code will throw back its
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
108 ;; head and scream.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
109
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
110 (defmacro itimer-decrement (variable)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
111 (list 'setq variable (list '1- variable)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
112
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
113 (defmacro itimer-increment (variable)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
114 (list 'setq variable (list '1+ variable)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
115
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
116 (defmacro itimer-signum (n)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
117 (list 'if (list '> n 0) 1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
118 (list 'if (list 'zerop n) 0 -1)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
119
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
120 ;; Itimer access functions should behave as if they were subrs. These
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
121 ;; macros are used to check the arguments to the itimer functions and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
122 ;; signal errors appropriately if the arguments are not valid.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
123
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
124 (defmacro check-itimer (var)
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
125 "If VAR is not bound to an itimer, signal `wrong-type-argument'.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
126 This is a macro."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
127 (list 'setq var
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
128 (list 'if (list 'itimerp var) var
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
129 (list 'signal ''wrong-type-argument
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
130 (list 'list ''itimerp var)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
131
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
132 (defmacro check-itimer-coerce-string (var)
2297
13a418960a88 [xemacs-hg @ 2004-09-22 02:05:42 by stephent]
stephent
parents: 2292
diff changeset
133 "If VAR is bound to a string, look up the itimer that it names and
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
134 bind VAR to it. Otherwise, if VAR is not bound to an itimer, signal
2297
13a418960a88 [xemacs-hg @ 2004-09-22 02:05:42 by stephent]
stephent
parents: 2292
diff changeset
135 `wrong-type-argument'. This is a macro."
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
136 (list 'setq var
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
137 (list 'cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
138 (list (list 'itimerp var) var)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
139 (list (list 'stringp var) (list 'get-itimer var))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
140 (list t (list 'signal ''wrong-type-argument
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
141 (list 'list ''string-or-itimer-p var))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
142
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
143 (defmacro check-nonnegative-number (var)
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
144 "If VAR is not bound to a number, signal `wrong-type-argument'.
2297
13a418960a88 [xemacs-hg @ 2004-09-22 02:05:42 by stephent]
stephent
parents: 2292
diff changeset
145 If VAR is not bound to a positive number, signal `args-out-of-range'.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
146 This is a macro."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
147 (list 'setq var
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
148 (list 'if (list 'not (list 'numberp var))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
149 (list 'signal ''wrong-type-argument
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
150 (list 'list ''natnump var))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
151 (list 'if (list '< var 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
152 (list 'signal ''args-out-of-range (list 'list var))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
153 var))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
154
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
155 (defmacro check-string (var)
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
156 "If VAR is not bound to a string, signal `wrong-type-argument'.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
157 This is a macro."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
158 (list 'setq var
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
159 (list 'if (list 'stringp var) var
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
160 (list 'signal ''wrong-type-argument
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
161 (list 'list ''stringp var)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
162
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
163 ;; Functions to access and modify itimer attributes.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
164
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
165 (defun itimerp (object)
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
166 "Return non-nil if OBJECT is an itimer."
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
167 (and (consp object) (eq (length object) 8)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
168
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
169 (defun itimer-live-p (object)
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
170 "Return non-nil if OBJECT is an itimer and is active.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
171 ``Active'' means Emacs will run it when it expires.
446
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
172 `activate-itimer' must be called on an itimer to make it active.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
173 Itimers started with `start-itimer' are automatically active."
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
174 (and (itimerp object) (memq object itimer-list)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
175
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
176 (defun itimer-name (itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
177 "Return the name of ITIMER."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
178 (check-itimer itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
179 (car itimer))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
180
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
181 (defun itimer-value (itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
182 "Return the number of seconds until ITIMER expires."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
183 (check-itimer itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
184 (nth 1 itimer))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
185
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
186 (defun itimer-restart (itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
187 "Return the value to which ITIMER will be set at restart.
430
a5df635868b2 Import from CVS: tag r21-2-23
cvs
parents: 428
diff changeset
188 The value nil is returned if this itimer isn't set to restart."
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
189 (check-itimer itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
190 (nth 2 itimer))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
191
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
192 (defun itimer-function (itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
193 "Return the function of ITIMER.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
194 This function is called each time ITIMER expires."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
195 (check-itimer itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
196 (nth 3 itimer))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
197
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
198 (defun itimer-is-idle (itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
199 "Return non-nil if ITIMER is an idle timer.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
200 Normal timers expire after a set interval. Idle timers expire
430
a5df635868b2 Import from CVS: tag r21-2-23
cvs
parents: 428
diff changeset
201 only after Emacs has been idle for a specific interval. ``Idle''
a5df635868b2 Import from CVS: tag r21-2-23
cvs
parents: 428
diff changeset
202 means no command events have occurred within the interval."
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
203 (check-itimer itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
204 (nth 4 itimer))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
205
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
206 (defun itimer-uses-arguments (itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
207 "Return non-nil if the function of ITIMER will be called with arguments.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
208 ITIMER's function is called with the arguments each time ITIMER expires.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
209 The arguments themselves are retrievable with `itimer-function-arguments'."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
210 (check-itimer itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
211 (nth 5 itimer))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
212
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
213 (defun itimer-function-arguments (itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
214 "Return the function arguments of ITIMER as a list.
430
a5df635868b2 Import from CVS: tag r21-2-23
cvs
parents: 428
diff changeset
215 ITIMER's function is called with these arguments each time ITIMER expires."
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
216 (check-itimer itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
217 (nth 6 itimer))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
218
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
219 (defun itimer-recorded-run-time (itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
220 (check-itimer itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
221 (nth 7 itimer))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
222
2285
914c5afaac33 [xemacs-hg @ 2004-09-20 19:11:29 by james]
james
parents: 2284
diff changeset
223 (defun set-itimer-name (itimer name)
914c5afaac33 [xemacs-hg @ 2004-09-20 19:11:29 by james]
james
parents: 2284
diff changeset
224 "Set the name of ITIMER to be NAME.
2303
0da64f4bd0bc [xemacs-hg @ 2004-09-22 22:14:47 by james]
james
parents: 2297
diff changeset
225 NAME is an identifier for the itimer. It must be a string. If an active
0da64f4bd0bc [xemacs-hg @ 2004-09-22 22:14:47 by james]
james
parents: 2297
diff changeset
226 itimer already exists with this name, an error is signaled."
2285
914c5afaac33 [xemacs-hg @ 2004-09-20 19:11:29 by james]
james
parents: 2284
diff changeset
227 (check-string name)
2303
0da64f4bd0bc [xemacs-hg @ 2004-09-22 22:14:47 by james]
james
parents: 2297
diff changeset
228 (and (itimer-live-p itimer)
0da64f4bd0bc [xemacs-hg @ 2004-09-22 22:14:47 by james]
james
parents: 2297
diff changeset
229 (get-itimer name)
0da64f4bd0bc [xemacs-hg @ 2004-09-22 22:14:47 by james]
james
parents: 2297
diff changeset
230 (error "itimer named \"%s\" already existing and activated" name))
2285
914c5afaac33 [xemacs-hg @ 2004-09-20 19:11:29 by james]
james
parents: 2284
diff changeset
231 (setcar itimer name))
914c5afaac33 [xemacs-hg @ 2004-09-20 19:11:29 by james]
james
parents: 2284
diff changeset
232
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
233 (defun set-itimer-value (itimer value)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
234 "Set the timeout value of ITIMER to be VALUE.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
235 Itimer will expire in this many seconds.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
236 If your version of Emacs supports floating point numbers then
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
237 VALUE can be a floating point number. Otherwise it
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
238 must be an integer.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
239 Returns VALUE."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
240 (check-itimer itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
241 (check-nonnegative-number value)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
242 (let ((inhibit-quit t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
243 ;; If the itimer is in the active list, and under the new
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
244 ;; timeout value would expire before we would normally
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
245 ;; wakeup, wakeup now and recompute a new wakeup time.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
246 (or (and (< value itimer-next-wakeup)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
247 (and (itimer-name itimer) (get-itimer (itimer-name itimer)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
248 (progn (itimer-driver-wakeup)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
249 (setcar (cdr itimer) value)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
250 (itimer-driver-wakeup)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
251 t ))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
252 (setcar (cdr itimer) value))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
253 value))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
254
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
255 ;; Same as set-itimer-value but does not wakeup the driver.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
256 ;; Only should be used by the drivers when processing expired timers.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
257 (defun set-itimer-value-internal (itimer value)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
258 (check-itimer itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
259 (check-nonnegative-number value)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
260 (setcar (cdr itimer) value))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
261
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
262 (defun set-itimer-restart (itimer restart)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
263 "Set the restart value of ITIMER to be RESTART.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
264 If RESTART is nil, ITIMER will not restart when it expires.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
265 If your version of Emacs supports floating point numbers then
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
266 RESTART can be a floating point number. Otherwise it
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
267 must be an integer.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
268 Returns RESTART."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
269 (check-itimer itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
270 (if restart (check-nonnegative-number restart))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
271 (setcar (cdr (cdr itimer)) restart))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
272
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
273 (defun set-itimer-function (itimer function)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
274 "Set the function of ITIMER to be FUNCTION.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
275 FUNCTION will be called when itimer expires.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
276 Returns FUNCTION."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
277 (check-itimer itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
278 (setcar (nthcdr 3 itimer) function))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
279
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
280 (defun set-itimer-is-idle (itimer flag)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
281 "Set flag that says whether ITIMER is an idle timer.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
282 If FLAG is non-nil, then ITIMER will be considered an idle timer.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
283 Returns FLAG."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
284 (check-itimer itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
285 (setcar (nthcdr 4 itimer) flag))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
286
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
287 (defun set-itimer-uses-arguments (itimer flag)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
288 "Set flag that says whether the function of ITIMER is called with arguments.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
289 If FLAG is non-nil, then the function will be called with one argument,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
290 otherwise the function will be called with no arguments.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
291 Returns FLAG."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
292 (check-itimer itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
293 (setcar (nthcdr 5 itimer) flag))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
294
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
295 (defun set-itimer-function-arguments (itimer &optional arguments)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
296 "Set the function arguments of ITIMER to be ARGUMENTS.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
297 The function of ITIMER will be called with ARGUMENTS when itimer expires.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
298 Returns ARGUMENTS."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
299 (check-itimer itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
300 (setcar (nthcdr 6 itimer) arguments))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
301
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
302 (defun set-itimer-recorded-run-time (itimer time)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
303 (check-itimer itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
304 (setcar (nthcdr 7 itimer) time))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
305
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
306 (defun get-itimer (name)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
307 "Return itimer named NAME, or nil if there is none."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
308 (check-string name)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
309 (assoc name itimer-list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
310
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
311 (defun read-itimer (prompt &optional initial-input)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
312 "Read the name of an itimer from the minibuffer and return the itimer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
313 associated with that name. The user is prompted with PROMPT.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
314 Optional second arg INITIAL-INPUT non-nil is inserted into the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
315 minibuffer as initial user input."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
316 (get-itimer (completing-read prompt itimer-list nil 'confirm initial-input)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
317
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
318 (defun delete-itimer (itimer)
430
a5df635868b2 Import from CVS: tag r21-2-23
cvs
parents: 428
diff changeset
319 "Deletes ITIMER. ITIMER may be an itimer or the name of one."
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
320 (check-itimer-coerce-string itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
321 (setq itimer-list (delq itimer itimer-list)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
322
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
323 (defun start-itimer (name function value &optional restart
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
324 is-idle with-args &rest function-arguments)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
325 "Start an itimer.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
326 Arguments are
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
327 NAME, FUNCTION, VALUE &optional RESTART, IS-IDLE, WITH-ARGS, &rest FUNCTION-ARGUMENTS.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
328 NAME is an identifier for the itimer. It must be a string. If an itimer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
329 already exists with this name, NAME will be modified slightly to make
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
330 it unique.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
331 FUNCTION should be a function (or symbol naming one). It
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
332 will be called each time the itimer expires with arguments of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
333 FUNCTION-ARGUMENTS. The function can access the itimer that
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
334 invoked it through the variable `current-itimer'. If WITH-ARGS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
335 is nil then FUNCTION is called with no arguments. This is for
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
336 backward compatibility with older versions of the itimer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
337 package which always called FUNCTION with no arguments.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
338 VALUE is the number of seconds until this itimer expires.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
339 If your version of Emacs supports floating point numbers then
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
340 VALUE can be a floating point number. Otherwise it
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
341 must be an integer.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
342 Optional fourth arg RESTART non-nil means that this itimer should be
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
343 restarted automatically after its function is called. Normally an itimer
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
344 is deleted at expiration after its function has returned.
430
a5df635868b2 Import from CVS: tag r21-2-23
cvs
parents: 428
diff changeset
345 If non-nil RESTART should be a number indicating the value at which the
a5df635868b2 Import from CVS: tag r21-2-23
cvs
parents: 428
diff changeset
346 itimer should be set at restart time.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
347 Optional fifth arg IS-IDLE specifies if this is an idle timer.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
348 Normal timers expire after a set interval. Idle timers expire
430
a5df635868b2 Import from CVS: tag r21-2-23
cvs
parents: 428
diff changeset
349 only after Emacs has been idle for specific interval. ``Idle''
a5df635868b2 Import from CVS: tag r21-2-23
cvs
parents: 428
diff changeset
350 means no command events have occurred within the interval.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
351 Returns the newly created itimer."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
352 (interactive
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
353 (list (completing-read "Start itimer: " itimer-list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
354 (read (completing-read "Itimer function: " obarray 'fboundp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
355 (let (value)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
356 (while (or (not (numberp value)) (< value 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
357 (setq value (read-from-minibuffer "Itimer value: " nil nil t)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
358 value)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
359 (let ((restart t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
360 (while (and restart (or (not (numberp restart)) (< restart 0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
361 (setq restart (read-from-minibuffer "Itimer restart: "
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
362 nil nil t)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
363 restart)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
364 ;; hard to imagine the user specifying these interactively
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
365 nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
366 nil ))
2309
d8c340c9adb6 [xemacs-hg @ 2004-09-26 02:20:30 by james]
james
parents: 2303
diff changeset
367 (check-string name)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
368 (check-nonnegative-number value)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
369 (if restart (check-nonnegative-number restart))
2309
d8c340c9adb6 [xemacs-hg @ 2004-09-26 02:20:30 by james]
james
parents: 2303
diff changeset
370 ;; Make proposed itimer name unique if it's not already.
d8c340c9adb6 [xemacs-hg @ 2004-09-26 02:20:30 by james]
james
parents: 2303
diff changeset
371 (let ((oname name)
d8c340c9adb6 [xemacs-hg @ 2004-09-26 02:20:30 by james]
james
parents: 2303
diff changeset
372 (num 2))
d8c340c9adb6 [xemacs-hg @ 2004-09-26 02:20:30 by james]
james
parents: 2303
diff changeset
373 (while (get-itimer name)
d8c340c9adb6 [xemacs-hg @ 2004-09-26 02:20:30 by james]
james
parents: 2303
diff changeset
374 (setq name (format "%s<%d>" oname num))
d8c340c9adb6 [xemacs-hg @ 2004-09-26 02:20:30 by james]
james
parents: 2303
diff changeset
375 (itimer-increment num)))
d8c340c9adb6 [xemacs-hg @ 2004-09-26 02:20:30 by james]
james
parents: 2303
diff changeset
376 (activate-itimer (list name value restart function is-idle
d8c340c9adb6 [xemacs-hg @ 2004-09-26 02:20:30 by james]
james
parents: 2303
diff changeset
377 with-args function-arguments (list 0 0 0)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
378 (car itimer-list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
379
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
380 (defun make-itimer ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
381 "Create an unactivated itimer.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
382 The itimer will not begin running until activated with `activate-itimer'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
383 Set the itimer's expire interval with `set-itimer-value'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
384 Set the itimer's function interval with `set-itimer-function'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
385 Once this is done, the timer can be activated."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
386 (list nil 0 nil 'ignore nil nil nil (list 0 0 0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
387
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
388 (defun activate-itimer (itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
389 "Activate ITIMER, which was previously created with `make-itimer'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
390 ITIMER will be added to the global list of running itimers,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
391 its FUNCTION will be called when it expires, and so on."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
392 (check-itimer itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
393 (if (memq itimer itimer-list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
394 (error "itimer already activated"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
395 (if (not (numberp (itimer-value itimer)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
396 (error "itimer timeout value not a number: %s" (itimer-value itimer)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
397 (if (<= (itimer-value itimer) 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
398 (error "itimer timeout value not positive: %s" (itimer-value itimer)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
399 ;; If there's no itimer driver/process, start one now.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
400 ;; Otherwise wake up the itimer driver so that seconds slept before
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
401 ;; the new itimer is created won't be counted against it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
402 (if (or itimer-process itimer-timer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
403 (itimer-driver-wakeup)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
404 (itimer-driver-start))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
405 ;; Roll a unique name for the timer if it doesn't have a name
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
406 ;; already.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
407 (if (not (stringp (car itimer)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
408 (let ((name "itimer-0")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
409 (oname "itimer-")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
410 (num 1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
411 (while (get-itimer name)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
412 (setq name (format "%s<%d>" oname num))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
413 (itimer-increment num))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
414 (setcar itimer name))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
415 ;; signal an error if the timer's name matches an already
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
416 ;; activated timer.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
417 (if (get-itimer (itimer-name itimer))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
418 (error "itimer named \"%s\" already existing and activated"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
419 (itimer-name itimer))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
420 (let ((inhibit-quit t))
2284
17dfe8e3aead [xemacs-hg @ 2004-09-20 18:11:33 by james]
james
parents: 613
diff changeset
421 (if itimer-timer
17dfe8e3aead [xemacs-hg @ 2004-09-20 18:11:33 by james]
james
parents: 613
diff changeset
422 ;; Modify the itimer timeout value as if it were begun
17dfe8e3aead [xemacs-hg @ 2004-09-20 18:11:33 by james]
james
parents: 613
diff changeset
423 ;; at the last time when the itimer driver was woken up.
17dfe8e3aead [xemacs-hg @ 2004-09-20 18:11:33 by james]
james
parents: 613
diff changeset
424 (set-itimer-value
17dfe8e3aead [xemacs-hg @ 2004-09-20 18:11:33 by james]
james
parents: 613
diff changeset
425 itimer
17dfe8e3aead [xemacs-hg @ 2004-09-20 18:11:33 by james]
james
parents: 613
diff changeset
426 (+ (itimer-value itimer)
17dfe8e3aead [xemacs-hg @ 2004-09-20 18:11:33 by james]
james
parents: 613
diff changeset
427 (itimer-time-difference (current-time)
17dfe8e3aead [xemacs-hg @ 2004-09-20 18:11:33 by james]
james
parents: 613
diff changeset
428 itimer-timer-last-wakeup))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
429 ;; add the itimer to the global list
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
430 (setq itimer-list (cons itimer itimer-list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
431 ;; If the itimer process is scheduled to wake up too late for
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
432 ;; the itimer we wake it up to calculate a correct wakeup
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
433 ;; value giving consideration to the newly added itimer.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
434 (if (< (itimer-value itimer) itimer-next-wakeup)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
435 (itimer-driver-wakeup))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
436
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
437 ;; User level functions to list and modify existing itimers.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
438 ;; Itimer Edit major mode, and the editing commands thereof.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
439
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
440 (defun list-itimers ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
441 "Pop up a buffer containing a list of all itimers.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
442 The major mode of the buffer is Itimer Edit mode. This major mode provides
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
443 commands to manipulate itimers; see the documentation for
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
444 `itimer-edit-mode' for more information."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
445 (interactive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
446 (let* ((buf (get-buffer-create "*Itimer List*"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
447 (opoint (point))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
448 (standard-output buf)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
449 (itimers (reverse itimer-list)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
450 (set-buffer buf)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
451 (itimer-edit-mode)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
452 (setq buffer-read-only nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
453 (erase-buffer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
454 (insert
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
455 "Name Value Restart Function Idle Arguments"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
456 "\n"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
457 "---- ----- ------- -------- ---- --------")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
458 (if (null itimer-edit-start-marker)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
459 (setq itimer-edit-start-marker (point)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
460 (while itimers
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
461 (newline 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
462 (prin1 (itimer-name (car itimers)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
463 (tab-to-tab-stop)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
464 (insert (itimer-truncate-string
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
465 (format "%5.5s" (itimer-value (car itimers))) 5))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
466 (tab-to-tab-stop)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
467 (insert (itimer-truncate-string
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
468 (format "%5.5s" (itimer-restart (car itimers))) 5))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
469 (tab-to-tab-stop)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
470 (insert (itimer-truncate-string
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
471 (format "%.19s" (itimer-function (car itimers))) 19))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
472 (tab-to-tab-stop)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
473 (if (itimer-is-idle (car itimers))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
474 (insert "yes")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
475 (insert "no"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
476 (tab-to-tab-stop)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
477 (if (itimer-uses-arguments (car itimers))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
478 (prin1 (itimer-function-arguments (car itimers)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
479 (prin1 'NONE))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
480 (setq itimers (cdr itimers)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
481 ;; restore point
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
482 (goto-char opoint)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
483 (if (< (point) itimer-edit-start-marker)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
484 (goto-char itimer-edit-start-marker))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
485 (setq buffer-read-only t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
486 (display-buffer buf)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
487
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
488 (defun edit-itimers ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
489 "Display a list of all itimers and select it for editing.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
490 The major mode of the buffer containing the listing is Itimer Edit mode.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
491 This major mode provides commands to manipulate itimers; see the documentation
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
492 for `itimer-edit-mode' for more information."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
493 (interactive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
494 ;; since user is editing, make sure displayed data is reasonably up-to-date
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
495 (if (or itimer-process itimer-timer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
496 (itimer-driver-wakeup))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
497 (list-itimers)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
498 (select-window (get-buffer-window "*Itimer List*"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
499 (goto-char itimer-edit-start-marker)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
500 (if itimer-list
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
501 (progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
502 (forward-sexp 2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
503 (backward-sexp)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
504 (message "type q to quit, ? for help"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
505
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
506 ;; no point in making this interactive.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
507 (defun itimer-edit-mode ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
508 "Major mode for manipulating itimers.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
509 Attributes of running itimers are changed by moving the cursor to the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
510 desired field and typing `s' to set that field. The field will then be
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
511 set to the value read from the minibuffer.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
512
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
513 Commands:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
514 TAB move forward a field
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
515 DEL move backward a field
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
516 s set a field
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
517 d delete the selected itimer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
518 x start a new itimer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
519 ? help"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
520 (kill-all-local-variables)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
521 (make-local-variable 'tab-stop-list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
522 (setq major-mode 'itimer-edit-mode
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
523 mode-name "Itimer Edit"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
524 truncate-lines t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
525 tab-stop-list '(22 32 40 60 67))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
526 (abbrev-mode 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
527 (auto-fill-mode 0)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
528 (buffer-disable-undo (current-buffer))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
529 (use-local-map itimer-edit-map)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
530 (set-syntax-table emacs-lisp-mode-syntax-table))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
531
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
532 (put 'itimer-edit-mode 'mode-class 'special)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
533
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
534 (defun itimer-edit-help ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
535 "Help function for Itimer Edit."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
536 (interactive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
537 (if (eq last-command 'itimer-edit-help)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
538 (describe-mode)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
539 (message "TAB, DEL select fields, (s)et field, (d)elete itimer (type ? for more help)")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
540
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
541 (defun itimer-edit-quit ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
542 "End Itimer Edit."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
543 (interactive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
544 (bury-buffer (current-buffer))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
545 (if (one-window-p t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
546 (switch-to-buffer (other-buffer (current-buffer)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
547 (delete-window)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
548
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
549 (defun itimer-edit-set-field ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
550 (interactive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
551 ;; First two lines in list buffer are headers.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
552 ;; Cry out against the luser who attempts to change a field there.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
553 (if (<= (point) itimer-edit-start-marker)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
554 (error ""))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
555 ;; field-value must be initialized to be something other than a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
556 ;; number, symbol, or list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
557 (let (itimer field (field-value ""))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
558 (setq itimer (save-excursion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
559 ;; read the name of the itimer from the beginning of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
560 ;; the current line.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
561 (beginning-of-line)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
562 (get-itimer (read (current-buffer))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
563 field (save-excursion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
564 (itimer-edit-beginning-of-field)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
565 (let ((opoint (point))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
566 (n 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
567 ;; count the number of sexprs until we reach the cursor
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
568 ;; and use this info to determine which field the user
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
569 ;; wants to modify.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
570 (beginning-of-line)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
571 (while (and (>= opoint (point)) (< n 6))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
572 (forward-sexp 2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
573 (backward-sexp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
574 (itimer-increment n))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
575 (cond ((eq n 1) (error "Cannot change itimer name."))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
576 ((eq n 2) 'value)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
577 ((eq n 3) 'restart)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
578 ((eq n 4) 'function)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
579 ((eq n 5) 'is-idle)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
580 (t 'function-argument)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
581 (cond ((eq field 'value)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
582 (let ((prompt "Set itimer value: "))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
583 (while (not (natnump field-value))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
584 (setq field-value (read-from-minibuffer prompt nil nil t)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
585 ((eq field 'restart)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
586 (let ((prompt "Set itimer restart: "))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
587 (while (and field-value (not (natnump field-value)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
588 (setq field-value (read-from-minibuffer prompt nil nil t)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
589 ((eq field 'function)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
590 (let ((prompt "Set itimer function: "))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
591 (while (not (or (and (symbolp field-value) (fboundp field-value))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
592 (and (consp field-value)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
593 (memq (car field-value) '(lambda macro)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
594 (setq field-value
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
595 (read (completing-read prompt obarray 'fboundp nil))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
596 ((eq field 'is-idle)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
597 (setq field-value (not (itimer-is-idle itimer))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
598 ((eq field 'function-argument)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
599 (let ((prompt "Set itimer function argument: "))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
600 (setq field-value (read-expression prompt))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
601 (cond ((not (listp field-value))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
602 (setq field-value (list field-value))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
603 (if (null field-value)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
604 (set-itimer-uses-arguments itimer nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
605 (set-itimer-uses-arguments itimer t)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
606 ;; set the itimer field
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
607 (funcall (intern (concat "set-itimer-" (symbol-name field)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
608 itimer field-value)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
609 ;; move to beginning of field to be changed
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
610 (itimer-edit-beginning-of-field)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
611 ;; modify the list buffer to reflect the change.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
612 (let (buffer-read-only kill-ring)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
613 (kill-sexp 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
614 (kill-region (point) (progn (skip-chars-forward " \t") (point)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
615 (prin1 field-value (current-buffer))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
616 (if (not (eolp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
617 (tab-to-tab-stop))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
618 (backward-sexp))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
619
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
620 (defun itimer-edit-delete-itimer ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
621 (interactive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
622 ;; First two lines in list buffer are headers.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
623 ;; Cry out against the luser who attempts to change a field there.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
624 (if (<= (point) itimer-edit-start-marker)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
625 (error ""))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
626 (delete-itimer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
627 (read-itimer "Delete itimer: "
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
628 (save-excursion (beginning-of-line) (read (current-buffer)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
629 ;; update list information
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
630 (list-itimers))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
631
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
632 (defun itimer-edit-next-field (count)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
633 (interactive "p")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
634 (itimer-edit-beginning-of-field)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
635 (cond ((> (itimer-signum count) 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
636 (while (not (zerop count))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
637 (forward-sexp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
638 ;; wrap from eob to itimer-edit-start-marker
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
639 (if (eobp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
640 (progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
641 (goto-char itimer-edit-start-marker)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
642 (forward-sexp)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
643 (forward-sexp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
644 (backward-sexp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
645 ;; treat fields at beginning of line as if they weren't there.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
646 (if (bolp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
647 (progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
648 (forward-sexp 2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
649 (backward-sexp)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
650 (itimer-decrement count)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
651 ((< (itimer-signum count) 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
652 (while (not (zerop count))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
653 (backward-sexp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
654 ;; treat fields at beginning of line as if they weren't there.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
655 (if (bolp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
656 (backward-sexp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
657 ;; wrap from itimer-edit-start-marker to field at eob.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
658 (if (<= (point) itimer-edit-start-marker)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
659 (progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
660 (goto-char (point-max))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
661 (backward-sexp)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
662 (itimer-increment count)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
663
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
664 (defun itimer-edit-previous-field (count)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
665 (interactive "p")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
666 (itimer-edit-next-field (- count)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
667
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
668 (defun itimer-edit-beginning-of-field ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
669 (let ((forw-back (save-excursion (forward-sexp) (backward-sexp) (point)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
670 (back (save-excursion (backward-sexp) (point))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
671 (cond ((eq forw-back back) (backward-sexp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
672 ((eq forw-back (point)) t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
673 (t (backward-sexp)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
674
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
675 (defun itimer-truncate-string (str len)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
676 (if (<= (length str) len)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
677 str
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
678 (substring str 0 len)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
679
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
680 ;; internals of the itimer implementation.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
681
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
682 (defun itimer-run-expired-timers (time-elapsed)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
683 (let ((itimers (copy-sequence itimer-list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
684 (itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
685 (next-wakeup 600)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
686 (idle-time)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
687 (last-event-time)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
688 (recorded-run-time)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
689 ;; process filters can be hit by stray C-g's from the user,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
690 ;; so we must protect this stuff appropriately.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
691 ;; Quit's are allowed from within itimer functions, but we
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
692 ;; catch them and print a message.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
693 (inhibit-quit t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
694 (setq next-wakeup 600)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
695 (cond ((and (boundp 'last-command-event-time)
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 430
diff changeset
696 (consp last-command-event-time))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
697 (setq last-event-time last-command-event-time
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
698 idle-time (itimer-time-difference (current-time)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
699 last-event-time)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
700 ((and (boundp 'last-input-time) (consp last-input-time))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
701 (setq last-event-time (list (car last-input-time)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
702 (cdr last-input-time)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
703 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
704 idle-time (itimer-time-difference (current-time)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
705 last-event-time)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
706 ;; no way to do this under FSF Emacs yet.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
707 (t (setq last-event-time '(0 0 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
708 idle-time 0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
709 (while itimers
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
710 (setq itimer (car itimers))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
711 (if (itimer-is-idle itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
712 (setq recorded-run-time (itimer-recorded-run-time itimer))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
713 (set-itimer-value-internal itimer (max 0 (- (itimer-value itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
714 time-elapsed))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
715 (if (if (itimer-is-idle itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
716 (or (> (itimer-time-difference recorded-run-time
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
717 last-event-time)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
718 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
719 (< idle-time (itimer-value itimer)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
720 (> (itimer-value itimer) 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
721 (setq next-wakeup
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
722 (if (itimer-is-idle itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
723 (if (< idle-time (itimer-value itimer))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
724 (min next-wakeup (- (itimer-value itimer) idle-time))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
725 (min next-wakeup (itimer-value itimer)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
726 (min next-wakeup (itimer-value itimer))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
727 (and (itimer-is-idle itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
728 (set-itimer-recorded-run-time itimer (current-time)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
729 ;; itimer has expired, we must call its function.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
730 ;; protect our local vars from the itimer function.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
731 ;; allow keyboard quit to occur, but catch and report it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
732 ;; provide the variable `current-itimer' in case the function
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
733 ;; is interested.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
734 (unwind-protect
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
735 (condition-case condition-data
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
736 (save-match-data
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
737 ;; Suppress warnings - see comment below.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
738 (defvar last-event-time)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
739 (defvar next-wakeup)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
740 (defvar itimer)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
741 (defvar itimers)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
742 (defvar time-elapsed)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
743 (let* ((current-itimer itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
744 (quit-flag nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
745 (inhibit-quit nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
746 ;; for FSF Emacs timer.el emulation under XEmacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
747 ;; eldoc expect this to be done, apparently.
430
a5df635868b2 Import from CVS: tag r21-2-23
cvs
parents: 428
diff changeset
748 (this-command nil)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
749 ;; bind these variables so that the itimer
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
750 ;; function can't screw with them.
430
a5df635868b2 Import from CVS: tag r21-2-23
cvs
parents: 428
diff changeset
751 last-event-time next-wakeup
a5df635868b2 Import from CVS: tag r21-2-23
cvs
parents: 428
diff changeset
752 itimer itimers time-elapsed)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
753 (if (itimer-uses-arguments current-itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
754 (apply (itimer-function current-itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
755 (itimer-function-arguments current-itimer))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
756 (funcall (itimer-function current-itimer)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
757 (error (message "itimer \"%s\" signaled: %s" (itimer-name itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
758 (prin1-to-string condition-data)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
759 (quit (message "itimer \"%s\" quit" (itimer-name itimer))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
760 ;; restart the itimer if we should, otherwise delete it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
761 (if (null (itimer-restart itimer))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
762 (delete-itimer itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
763 (set-itimer-value-internal itimer (itimer-restart itimer))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
764 (setq next-wakeup (min next-wakeup (itimer-value itimer))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
765 (setq itimers (cdr itimers)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
766 ;; make another sweep through the list to catch any timers
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
767 ;; that might have been added by timer functions above.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
768 (setq itimers itimer-list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
769 (while itimers
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
770 (setq next-wakeup (min next-wakeup (itimer-value (car itimers)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
771 itimers (cdr itimers)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
772 ;; if user is viewing the timer list, update displayed info.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
773 (let ((b (get-buffer "*Itimer List*")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
774 (if (and b (get-buffer-window b))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
775 (save-excursion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
776 (list-itimers))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
777 next-wakeup ))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
778
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
779 (defun itimer-process-filter (process string)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
780 ;; If the itimer process dies and generates output while doing
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
781 ;; so, we may be called before the process-sentinel. Sanity
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
782 ;; check the output just in case...
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
783 (if (not (string-match "^[0-9]" string))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
784 (progn (message "itimer process gave odd output: %s" string)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
785 ;; it may be still alive and waiting for input
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
786 (process-send-string itimer-process "3\n"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
787 ;; if there are no active itimers, return quickly.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
788 (if itimer-list
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
789 (let ((wakeup nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
790 (unwind-protect
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
791 (setq wakeup (itimer-run-expired-timers (string-to-int string)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
792 (and (null wakeup) (process-send-string process "1\n")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
793 (setq itimer-next-wakeup wakeup))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
794 (setq itimer-next-wakeup 600))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
795 ;; tell itimer-process when to wakeup again
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
796 (process-send-string itimer-process
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
797 (concat (int-to-string itimer-next-wakeup)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
798 "\n"))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
799
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
800 (defun itimer-process-sentinel (process message)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
801 (let ((inhibit-quit t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
802 (if (eq (process-status process) 'stop)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
803 (continue-process process)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
804 ;; not stopped, so it must have died.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
805 ;; cleanup first...
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
806 (delete-process process)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
807 (setq itimer-process nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
808 ;; now, if there are any active itimers then we need to immediately
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
809 ;; start another itimer process, otherwise we can wait until the next
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
810 ;; start-itimer call, which will start one automatically.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
811 (if (null itimer-list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
812 ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
813 ;; there may have been an error message in the echo area;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
814 ;; give the user at least a little time to read it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
815 (sit-for 2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
816 (message "itimer process %s... respawning." (substring message 0 -1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
817 (itimer-process-start)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
818
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
819 (defun itimer-process-start ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
820 (let ((inhibit-quit t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
821 (process-connection-type nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
822 (setq itimer-process (start-process "itimer" nil "itimer"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
823 (process-kill-without-query itimer-process)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
824 (set-process-filter itimer-process 'itimer-process-filter)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
825 (set-process-sentinel itimer-process 'itimer-process-sentinel)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
826 ;; Tell itimer process to wake up quickly, so that a correct
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
827 ;; wakeup time can be computed. Zero loses because of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
828 ;; underlying itimer implementations that use 0 to mean
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
829 ;; `disable the itimer'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
830 (setq itimer-next-wakeup itimer-short-interval)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
831 (process-send-string itimer-process
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
832 (format "%s\n" itimer-next-wakeup))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
833
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
834 (defun itimer-process-wakeup ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
835 (interrupt-process itimer-process)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
836 (accept-process-output))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
837
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
838 (defun itimer-timer-start ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
839 (let ((inhibit-quit t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
840 (setq itimer-next-wakeup itimer-short-interval
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
841 itimer-timer-last-wakeup (current-time)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
842 itimer-timer (add-timeout itimer-short-interval
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
843 'itimer-timer-driver nil nil))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
844
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
845 (defun itimer-disable-timeout (timeout)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
846 ;; Disgusting hack, but necessary because there is no other way
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
847 ;; to remove a timer that has a restart value from while that
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
848 ;; timer's function is being run. (FSF Emacs only.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
849 (if (vectorp timeout)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
850 (aset timeout 4 nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
851 (disable-timeout timeout))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
852
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
853 (defun itimer-timer-wakeup ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
854 (let ((inhibit-quit t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
855 (itimer-disable-timeout itimer-timer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
856 (setq itimer-timer (add-timeout itimer-short-interval
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
857 'itimer-timer-driver nil 5))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
858
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
859 (defun itimer-time-difference (t1 t2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
860 (let (usecs secs 65536-secs carry)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
861 (setq usecs (- (nth 2 t1) (nth 2 t2)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
862 (if (< usecs 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
863 (setq carry 1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
864 usecs (+ usecs 1000000))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
865 (setq carry 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
866 (setq secs (- (nth 1 t1) (nth 1 t2) carry))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
867 (if (< secs 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
868 (setq carry 1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
869 secs (+ secs 65536))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
870 (setq carry 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
871 (setq 65536-secs (- (nth 0 t1) (nth 0 t2) carry))
430
a5df635868b2 Import from CVS: tag r21-2-23
cvs
parents: 428
diff changeset
872 (+ (* 65536-secs 65536.0)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
873 secs
430
a5df635868b2 Import from CVS: tag r21-2-23
cvs
parents: 428
diff changeset
874 (/ usecs 1000000.0))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
875
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
876 (defun itimer-timer-driver (&rest ignored)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
877 ;; inhibit quit because if the user quits at an inopportune
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
878 ;; time, the timer process won't be launched again and the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
879 ;; system stops working. itimer-run-expired-timers allows
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
880 ;; individual timer function to be aborted, so the user can
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
881 ;; escape a feral timer function.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
882 (if (not itimer-inside-driver)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
883 (let* ((inhibit-quit t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
884 (itimer-inside-driver t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
885 (now (current-time))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
886 (elapsed (itimer-time-difference now itimer-timer-last-wakeup))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
887 (sleep nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
888 (setq itimer-timer-last-wakeup now
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
889 sleep (itimer-run-expired-timers elapsed))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
890 (itimer-disable-timeout itimer-timer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
891 (setq itimer-next-wakeup sleep
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
892 itimer-timer (add-timeout sleep 'itimer-timer-driver nil 5)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
893
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
894 (defun itimer-driver-start ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
895 (if (fboundp 'add-timeout)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
896 (itimer-timer-start)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
897 (itimer-process-start)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
898
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
899 (defun itimer-driver-wakeup ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
900 (if (fboundp 'add-timeout)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
901 (itimer-timer-wakeup)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
902 (itimer-process-wakeup)))