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

Contents of /climacs/file-commands.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.30 - (show annotations)
Sat Jan 26 23:06:04 2008 UTC (6 years, 2 months ago) by thenriksen
Branch: MAIN
Changes since 1.29: +3 -1 lines
Make defaults for view-switching slightly nicer.
1 ;;; -*- Mode: Lisp; Package: CLIMACS-GUI -*-
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
12 ;;; This library is free software; you can redistribute it and/or
13 ;;; modify it under the terms of the GNU Library General Public
14 ;;; License as published by the Free Software Foundation; either
15 ;;; version 2 of the License, or (at your option) any later version.
16 ;;;
17 ;;; This library is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
20 ;;; Library General Public License for more details.
21 ;;;
22 ;;; You should have received a copy of the GNU Library General Public
23 ;;; License along with this library; if not, write to the
24 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;;; Boston, MA 02111-1307 USA.
26
27 ;;; File (and buffer) commands for the Climacs editor. Note that many
28 ;;; basic commands (such as Find File) are defined in ESA and made
29 ;;; available to Climacs via the ESA-IO-TABLE command table.
30
31 (in-package :climacs-commands)
32
33 (define-command (com-reparse-attribute-list :name t :command-table buffer-table)
34 ()
35 "Reparse the current buffer's attribute list.
36 An attribute list is a line of keyword-value pairs, each keyword separated
37 from the corresponding value by a colon. If another keyword-value pair
38 follows, the value should be terminated by a colon. The attribute list
39 is surrounded by '-*-' sequences, but the opening '-*-' need not be at the
40 beginning of the line. Climacs looks for the attribute list
41 on the first or second non-blank line of the file.
42
43 An example attribute-list is:
44
45 ;; -*- Syntax: Lisp; Base: 10 -*- "
46 (evaluate-attribute-line (current-buffer)))
47
48 (define-command (com-update-attribute-list :name t :command-table buffer-table)
49 ()
50 "Update the current buffers attribute list to reflect the
51 settings of the syntax of the buffer.
52
53 After the attribute list has been updated, it will also be
54 re-evaluated. An attribute list is a line of keyword-value pairs,
55 each keyword separated from the corresponding value by a
56 colon. If another keyword-value pair follows, the value should be
57 terminated by a colon. The attribute list is surrounded by '-*-'
58 sequences, but the opening '-*-' need not be at the beginning of
59 the line. Climacs looks for the attribute list on the first or
60 second non-blank line of the file.
61
62 An example attribute-list is:
63
64 ;; -*- Syntax: Lisp; Base: 10 -*-
65
66 This command automatically comments the attribute line as
67 appropriate for the syntax of the buffer."
68 (update-attribute-line (current-buffer))
69 (evaluate-attribute-line (current-buffer)))
70
71 (define-command (com-insert-file :name t :command-table buffer-table)
72 ((filename 'pathname :prompt "Insert File"
73 :default (directory-of-buffer (current-buffer))
74 :default-type 'pathname
75 :insert-default t))
76 "Prompt for a filename and insert its contents at point.
77 Leaves mark after the inserted contents."
78 (when (probe-file filename)
79 (setf (mark) (clone-mark (point) :left))
80 (with-open-file (stream filename :direction :input)
81 (input-from-stream stream
82 (current-buffer)
83 (offset (point))))
84 (psetf (offset (mark)) (offset (point))
85 (offset (point)) (offset (mark))))
86 (redisplay-frame-panes *application-frame*))
87
88 (set-key `(com-insert-file ,*unsupplied-argument-marker*)
89 'buffer-table
90 '((#\x :control) (#\i :control)))
91
92 (define-command (com-revert-buffer :name t :command-table buffer-table) ()
93 "Replace the contents of the current buffer with the visited file.
94 Signals an error if the file does not exist."
95 (let* ((save (offset (point)))
96 (filepath (filepath (current-buffer))))
97 (when (accept 'boolean :prompt (format nil "Revert buffer from file ~A?"
98 filepath))
99 (cond ((directory-pathname-p filepath)
100 (display-message "~A is a directory name." filepath)
101 (beep))
102 ((probe-file filepath)
103 (unless (check-file-times (current-buffer) filepath "Revert" "reverted")
104 (return-from com-revert-buffer))
105 (erase-buffer (current-buffer))
106 (with-open-file (stream filepath :direction :input)
107 (input-from-stream stream (current-buffer) 0))
108 (setf (offset (point)) (min (size (current-buffer)) save)
109 (file-saved-p (current-buffer)) nil))
110 (t
111 (display-message "No file ~A" filepath)
112 (beep))))))
113
114 (defun load-file (file-name)
115 (cond ((directory-pathname-p file-name)
116 (display-message "~A is a directory name." file-name)
117 (beep))
118 (t
119 (cond ((probe-file file-name)
120 (load file-name))
121 (t
122 (display-message "No such file: ~A" file-name)
123 (beep))))))
124
125 (define-command (com-load-file :name t :command-table base-table) ()
126 "Prompt for a filename and CL:LOAD that file.
127 Signals and error if the file does not exist."
128 (let ((filepath (accept 'pathname :prompt "Load File")))
129 (load-file filepath)))
130
131 (set-key 'com-load-file
132 'base-table
133 '((#\c :control) (#\l :control)))
134
135 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
136 ;;;
137 ;;; Buffer commands
138
139 (define-command (com-switch-to-view :name t :command-table pane-table)
140 ;; Perhaps the default should be an undisplayed view?
141 ((view 'view :default (or (find (current-view) (views *application-frame*)
142 :test (complement #'eq))
143 (any-view))))
144 "Prompt for a buffer name and switch to that buffer.
145 If the a buffer with that name does not exist, create it. Uses
146 the name of the next buffer (if any) as a default."
147 (handler-case (switch-to-view (current-window) view)
148 (view-already-displayed (condition)
149 (other-window (window condition)))))
150
151 (set-key `(com-switch-to-view ,*unsupplied-argument-marker*)
152 'pane-table
153 '((#\x :control) (#\b)))
154
155 (define-command (com-kill-view :name t :command-table pane-table)
156 ((view 'view :prompt "Kill view"
157 :default (current-view)))
158 "Prompt for a view name and kill that view.
159 If the view is of a buffer and the buffer needs saving, you will
160 be prompted to do so before killing it. Uses the current view
161 as a default."
162 (kill-view view))
163
164 (set-key `(com-kill-view ,*unsupplied-argument-marker*)
165 'pane-table
166 '((#\x :control) (#\k)))
167
168 (define-command (com-toggle-read-only :name t :command-table buffer-table)
169 ((buffer 'buffer :default (current-buffer *application-frame*)))
170 (setf (read-only-p buffer) (not (read-only-p buffer))))
171
172 (define-presentation-to-command-translator toggle-read-only
173 (read-only com-toggle-read-only buffer-table
174 :gesture :menu)
175 (object)
176 (list object))
177
178 (define-command (com-toggle-modified :name t :command-table buffer-table)
179 ((buffer 'buffer :default (current-buffer *application-frame*)))
180 (setf (needs-saving buffer) (not (needs-saving buffer))))
181
182 (define-presentation-to-command-translator toggle-modified
183 (modified com-toggle-modified buffer-table
184 :gesture :menu)
185 (object)
186 (list object))

  ViewVC Help
Powered by ViewVC 1.1.5