-
Notifications
You must be signed in to change notification settings - Fork 2
/
file-commands.lisp
157 lines (134 loc) · 6.06 KB
/
file-commands.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
;;; -*- Mode: Lisp; Package: CLIMACS-GUI -*-
;;; (c) copyright 2004-2005 by
;;; Robert Strandh ([email protected])
;;; (c) copyright 2004-2005 by
;;; Elliott Johnson ([email protected])
;;; (c) copyright 2005 by
;;; Matthieu Villeneuve ([email protected])
;;; (c) copyright 2005 by
;;; Aleksandar Bakic ([email protected])
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
;;; File (and buffer) commands for the Climacs editor. Note that many
;;; basic commands (such as Find File) are defined in ESA and made
;;; available to Climacs via the ESA-IO-TABLE command table.
(in-package :climacs-commands)
(define-command (com-reparse-attribute-list :name t :command-table buffer-table)
()
"Reparse the current buffer's attribute list.
An attribute list is a line of keyword-value pairs, each keyword separated
from the corresponding value by a colon. If another keyword-value pair
follows, the value should be terminated by a colon. The attribute list
is surrounded by '-*-' sequences, but the opening '-*-' need not be at the
beginning of the line. Climacs looks for the attribute list
on the first or second non-blank line of the file.
An example attribute-list is:
;; -*- Syntax: Lisp; Base: 10 -*- "
(evaluate-attribute-line (current-buffer)))
(define-command (com-update-attribute-list :name t :command-table buffer-table)
()
"Update the current buffers attribute list to reflect the
settings of the syntax of the buffer.
After the attribute list has been updated, it will also be
re-evaluated. An attribute list is a line of keyword-value pairs,
each keyword separated from the corresponding value by a
colon. If another keyword-value pair follows, the value should be
terminated by a colon. The attribute list is surrounded by '-*-'
sequences, but the opening '-*-' need not be at the beginning of
the line. Climacs looks for the attribute list on the first or
second non-blank line of the file.
An example attribute-list is:
;; -*- Syntax: Lisp; Base: 10 -*-
This command automatically comments the attribute line as
appropriate for the syntax of the buffer."
(update-attribute-line (current-buffer))
(evaluate-attribute-line (current-buffer)))
(define-command (com-insert-file :name t :command-table buffer-table)
((filename 'pathname :prompt "Insert File"
:default (directory-of-buffer (current-buffer))
:default-type 'pathname
:insert-default t))
"Prompt for a filename and insert its contents at point.
Leaves mark after the inserted contents."
(when (probe-file filename)
(setf (mark) (clone-mark (point) :left))
(with-open-file (stream filename :direction :input)
(input-from-stream stream
(current-buffer)
(offset (point))))
(psetf (offset (mark)) (offset (point))
(offset (point)) (offset (mark))))
(redisplay-frame-panes *application-frame*))
(set-key `(com-insert-file ,*unsupplied-argument-marker*)
'buffer-table
'((#\x :control) (#\i :control)))
(define-command (com-revert-buffer :name t :command-table buffer-table) ()
"Replace the contents of the current buffer with the visited file.
Signals an error if the file does not exist."
(let* ((save (offset (point)))
(filepath (filepath (current-buffer))))
(when (accept 'boolean :prompt (format nil "Revert buffer from file ~A?"
filepath))
(cond ((directory-pathname-p filepath)
(display-message "~A is a directory name." filepath)
(beep))
((probe-file filepath)
(unless (check-file-times (current-buffer) filepath "Revert" "reverted")
(return-from com-revert-buffer))
(erase-buffer (current-buffer))
(with-open-file (stream filepath :direction :input)
(input-from-stream stream (current-buffer) 0))
(setf (offset (point)) (min (size (current-buffer)) save)
(file-saved-p (current-buffer)) nil))
(t
(display-message "No file ~A" filepath)
(beep))))))
(defun load-file (file-name)
(cond ((directory-pathname-p file-name)
(display-message "~A is a directory name." file-name)
(beep))
(t
(cond ((probe-file file-name)
(load file-name))
(t
(display-message "No such file: ~A" file-name)
(beep))))))
(define-command (com-load-file :name t :command-table base-table) ()
"Prompt for a filename and CL:LOAD that file.
Signals and error if the file does not exist."
(let ((filepath (accept 'pathname :prompt "Load File")))
(load-file filepath)))
(set-key 'com-load-file
'base-table
'((#\c :control) (#\l :control)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Buffer commands
(define-command (com-toggle-read-only :name t :command-table buffer-table)
((buffer 'buffer :default (current-buffer *application-frame*)))
(setf (read-only-p buffer) (not (read-only-p buffer))))
(define-presentation-to-command-translator toggle-read-only
(read-only com-toggle-read-only buffer-table
:gesture :menu)
(object)
(list object))
(define-command (com-toggle-modified :name t :command-table buffer-table)
((buffer 'buffer :default (current-buffer *application-frame*)))
(setf (needs-saving buffer) (not (needs-saving buffer))))
(define-presentation-to-command-translator toggle-modified
(modified com-toggle-modified buffer-table
:gesture :menu)
(object)
(list object))