source: trunk/abcl/src/org/armedbear/lisp/ed.lisp @ 11457

Last change on this file since 11457 was 11391, checked in by vvoutilainen, 13 years ago

ABCL license is GPL + Classpath exception. This was intended
by Peter Graves, the original author. For reference, see
http://sourceforge.net/mailarchive/forum.php?thread_name=20040721115302.839%40prufrock&forum_name=armedbear-j-announce

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 6.3 KB
Line 
1;;; ed.lisp
2;;;
3;;; Copyright (C) 2004-2007 Peter Graves
4;;; $Id: ed.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32;;; Adapted from SBCL.
33
34(in-package #:system)
35
36(defun ed (&optional x)
37  "Starts the editor (on a file or a function if named).  Functions
38from the list *ED-FUNCTIONS* are called in order with X as an argument
39until one of them returns non-NIL; these functions are responsible for
40signalling a FILE-ERROR to indicate failure to perform an operation on
41the file system."
42  (dolist (fun *ed-functions*
43     (error 'simple-error
44      :format-control "Don't know how to ~S ~A"
45      :format-arguments (list 'ed x)))
46    (when (funcall fun x)
47      (return)))
48  (values))
49
50(defun default-ed-function (what)
51  (let ((portfile (merge-pathnames ".j/port"
52                                   (if (featurep :windows)
53                                       (if (ext:probe-directory "C:\\.j")
54                                           "C:\\"
55                                           (ext:probe-directory (pathname (ext:getenv "APPDATA"))))
56                                       (user-homedir-pathname))))
57        stream)
58    (when (probe-file portfile)
59      (let* ((port (with-open-file (s portfile) (read s nil nil)))
60             (socket (and (integerp port) (make-socket "127.0.0.1" port))))
61        (setf stream (and socket (get-socket-stream socket)))))
62    (unwind-protect
63     (cond ((stringp what)
64            (if stream
65                (progn
66                  (write-string (namestring (user-homedir-pathname)) stream)
67                  (terpri stream)
68                  (write-string (format nil "~S~%" what) stream))
69                (run-shell-command (format nil "j ~S" what))))
70           ((and what (symbolp what))
71            (when (autoloadp what)
72              (let ((*load-verbose* nil)
73                    (*load-print* nil)
74                    (*autoload-verbose* nil))
75                (resolve what)))
76            (cond ((source what)
77                   (let ((file (namestring (source-pathname what)))
78                         (position (source-file-position what))
79                         (line-number 1)
80                         (pattern (string what)))
81                     (with-open-file (s file)
82                       (dotimes (i position)
83                         (let ((c (read-char s nil s)))
84                           (cond ((eq c s)
85                                  (return))
86                                 ((eql c #\newline)
87                                  (incf line-number)))))
88                       (dotimes (i 10)
89                         (let ((text (read-line s nil s)))
90                           (cond ((eq text s)
91                                  (return))
92                                 ((search pattern text :test 'string-equal)
93                                  (return))
94                                 (t
95                                  (incf line-number))))))
96                     (if stream
97                         (progn
98                           (write-string (namestring (user-homedir-pathname)) stream)
99                           (terpri stream)
100                           (write-string (format nil "+~D~%~S~%" line-number file) stream))
101                         (run-shell-command (format nil "j +~D ~S" line-number file)))))
102                  ((not (null *lisp-home*))
103                   (let ((tagfile (merge-pathnames "tags" *lisp-home*)))
104                     (when (and tagfile (probe-file tagfile))
105                       (with-open-file (s tagfile)
106                         (loop
107                           (let ((text (read-line s nil s)))
108                             (cond ((eq text s)
109                                    (return))
110                                   ((eq what (read-from-string text nil nil))
111                                    ;; Found it!
112                                    (with-input-from-string (string-stream text)
113                                      (let* ((symbol (read string-stream text nil nil)) ; Ignored.
114                                             (file (read string-stream text nil nil))
115                                             (line-number (read string-stream text nil nil)))
116                                        (declare (ignore symbol))
117                                        (when (pathnamep file)
118                                          (setf file (namestring file)))
119                                        (if stream
120                                            (progn
121                                              (write-string (namestring (user-homedir-pathname)) stream)
122                                              (terpri stream)
123                                              (write-string (format nil "+~D~%~S~%" line-number file) stream))
124                                            (run-shell-command (format nil "j +~D ~S" line-number file))))))))))))))))
125     (when stream
126       (close stream))))
127  t)
Note: See TracBrowser for help on using the repository browser.