/[climacs]/climacs/misc-commands.lisp
ViewVC logotype

Contents of /climacs/misc-commands.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.31 - (show annotations)
Mon Apr 28 20:50:11 2008 UTC (5 years, 11 months ago) by thenriksen
Branch: MAIN
CVS Tags: HEAD
Changes since 1.30: +1 -1 lines
Explicitly specifying :SHIFT is not required anymore.
1 ;;; -*- Mode: Lisp; Package: CLIMACS-COMMANDS -*-
2
3 ;;; (c) copyright 2004-2005 by
4 ;;; Robert Strandh (strandh@labri.fr)
5 ;;; (c) copyright 2004-2005 by
6 ;;; Elliott Johnson (ejohnson@fasl.info)
7 ;;; (c) copyright 2005 by
8 ;;; Matthieu Villeneuve (matthieu.villeneuve@free.fr)
9 ;;; (c) copyright 2005 by
10 ;;; Aleksandar Bakic (a_bakic@yahoo.com)
11 ;;; (c) copyright 2007 by
12 ;;; Troels Henriksen (athas@sigkill.dk)
13
14 ;;; This library is free software; you can redistribute it and/or
15 ;;; modify it under the terms of the GNU Library General Public
16 ;;; License as published by the Free Software Foundation; either
17 ;;; version 2 of the License, or (at your option) any later version.
18 ;;;
19 ;;; This library is distributed in the hope that it will be useful,
20 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
21 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
22 ;;; Library General Public License for more details.
23 ;;;
24 ;;; You should have received a copy of the GNU Library General Public
25 ;;; License along with this library; if not, write to the
26 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
27 ;;; Boston, MA 02111-1307 USA.
28
29 ;;; miscellaneous commands for the Climacs editor.
30
31 (in-package :climacs-commands)
32
33 (define-command (com-not-modified :name t :command-table buffer-table) ()
34 "Clear the modified flag for the current buffer.
35 The modified flag is automatically set when the contents
36 of the buffer are changed. This flag is consulted, for instance,
37 when deciding whether to prompt you to save the buffer before killing it."
38 (setf (needs-saving (current-buffer)) nil))
39
40 (set-key 'com-not-modified
41 'buffer-table
42 '((#\~ :meta)))
43
44 (define-command (com-what-cursor-position :name t :command-table info-table) ()
45 "Print information about point.
46 Gives the character after point (name and octal, decimal and hexidecimal charcode),
47 the offset of point, the total objects in the buffer,
48 and the percentage of the buffers objects before point.
49
50 FIXME: gives no information at end of buffer."
51 (let* ((char (or (end-of-buffer-p (point)) (object-after (point))))
52 (column (column-number (point))))
53 (display-message "Char: ~:[none~*~;~:*~:C (#o~O ~:*~D ~:*#x~X)~] point=~D of ~D (~D%) column ~D"
54 (and (characterp char) char)
55 (and (characterp char) (char-code char))
56 (offset (point)) (size (current-buffer))
57 (if (size (current-buffer))
58 (round (* 100 (/ (offset (point))
59 (size (current-buffer)))))
60 100)
61 column)))
62
63 (set-key 'com-what-cursor-position
64 'info-table
65 '((#\x :control) (#\=)))
66
67 (define-command (com-browse-url :name t :command-table base-table)
68 ((url 'url :prompt "Browse URL"))
69 (declare (ignorable url))
70 #+ (and sbcl darwin)
71 (sb-ext:run-program "/usr/bin/open" `(,url) :wait nil)
72 #+ (and openmcl darwin)
73 (ccl:run-program "/usr/bin/open" `(,url) :wait nil))
74
75 (define-command (com-set-syntax :name t :command-table buffer-table)
76 ((syntax 'syntax
77 :prompt "Name of syntax"))
78 "Prompts for a syntax to set for the current buffer.
79 Setting a syntax will cause the buffer to be reparsed using the new syntax."
80 (set-syntax (current-view) syntax))
81
82 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
83 ;;;
84 ;;; Groups
85
86 (define-command (com-define-group :name t :command-table global-climacs-table)
87 ((name 'string :prompt "Name")
88 (views '(sequence view) :prompt "Views"))
89 (when (or (not (get-group name))
90 (accept 'boolean :prompt "Group already exists. Overwrite existing group?"))
91 (add-group name views))
92 (select-group (get-group name)))
93
94 (set-key `(com-define-group ,*unsupplied-argument-marker* ,*unsupplied-argument-marker*)
95 'global-climacs-table
96 '((#\x :control) (#\g) (#\d)))
97
98 (define-command (com-define-file-group :name t :command-table global-climacs-table)
99 ((name 'string :prompt "Name")
100 (pathnames '(sequence pathname) :prompt "Files"))
101 (when (or (not (get-group name))
102 (accept 'boolean :prompt "Group already exists. Overwrite existing group?"))
103 (add-group name pathnames))
104 (select-group (get-group name)))
105
106 (set-key `(com-define-file-group ,*unsupplied-argument-marker* ,*unsupplied-argument-marker*)
107 'global-climacs-table
108 '((#\x :control) (#\g) (#\f)))
109
110 (define-command (com-select-group :name t :command-table global-climacs-table)
111 ((group 'group))
112 (select-group group))
113
114 (set-key `(com-select-group ,*unsupplied-argument-marker*)
115 'global-climacs-table
116 '((#\x :control) (#\g) (#\s)))
117
118 (define-command (com-deselect-group :name t :command-table global-climacs-table)
119 ()
120 (deselect-group)
121 (display-message "Group deselected"))
122
123 (set-key 'com-deselect-group
124 'global-climacs-table
125 '((#\x :control) (#\g) (#\u)))
126
127 (define-command (com-current-group :name t :command-table global-climacs-table)
128 ()
129 (with-minibuffer-stream (s)
130 (format s "Active group is: ")
131 (present (get-active-group) 'group :stream s)))
132
133 (set-key 'com-current-group
134 'global-climacs-table
135 '((#\x :control) (#\g) (#\c)))
136
137 (define-command (com-list-group-contents :name t :command-table global-climacs-table)
138 ()
139 (with-minibuffer-stream (s)
140 (format s "Active group designates: ")
141 (display-group-contents (get-active-group) s)))
142
143 (set-key 'com-list-group-contents
144 'global-climacs-table
145 '((#\x :control) (#\g) (#\l)))

  ViewVC Help
Powered by ViewVC 1.1.5