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

Contents of /climacs/file-commands.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.28 - (show annotations)
Tue Nov 20 12:59:54 2007 UTC (6 years, 5 months ago) by thenriksen
Branch: MAIN
Changes since 1.27: +24 -27 lines
Fixed Climacs to adapt to changes in Drei.
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-buffer :name t :command-table pane-table)
140 ((buffer 'buffer :default (or (second (buffers *application-frame*))
141 (any-buffer))))
142 "Prompt for a buffer name and switch to that buffer.
143 If the a buffer with that name does not exist, create it. Uses
144 the name of the next buffer (if any) as a default."
145 (switch-to-buffer (current-window) buffer))
146
147 (set-key `(com-switch-to-buffer ,*unsupplied-argument-marker*)
148 'pane-table
149 '((#\x :control) (#\b)))
150
151 (define-command (com-kill-buffer :name t :command-table pane-table)
152 ((buffer 'buffer
153 :prompt "Kill buffer"
154 :default (current-buffer)))
155 "Prompt for a buffer name and kill that buffer.
156 If the buffer needs saving, will prompt you to do so before killing it. Uses the current buffer as a default."
157 (kill-buffer buffer))
158
159 (set-key `(com-kill-buffer ,*unsupplied-argument-marker*)
160 'pane-table
161 '((#\x :control) (#\k)))
162
163 (define-command (com-toggle-read-only :name t :command-table buffer-table)
164 ((buffer 'buffer :default (current-buffer *application-frame*)))
165 (setf (read-only-p buffer) (not (read-only-p buffer))))
166
167 (define-presentation-to-command-translator toggle-read-only
168 (read-only com-toggle-read-only buffer-table
169 :gesture :menu)
170 (object)
171 (list object))
172
173 (define-command (com-toggle-modified :name t :command-table buffer-table)
174 ((buffer 'buffer :default (current-buffer *application-frame*)))
175 (setf (needs-saving buffer) (not (needs-saving buffer))))
176
177 (define-presentation-to-command-translator toggle-modified
178 (modified com-toggle-modified buffer-table
179 :gesture :menu)
180 (object)
181 (list object))

  ViewVC Help
Powered by ViewVC 1.1.5