[Initial version of cke site-lisp system clinton@unknownlamer.org**20060906050941] { adddir ./site-lisp adddir ./init.d addfile ./site-lisp/http-cookies.el addfile ./site-lisp/http-get.el addfile ./site-lisp/http-post.el addfile ./site-lisp/javascript.el addfile ./site-lisp/lj-acct.el addfile ./site-lisp/lj-compat.el addfile ./site-lisp/lj-compose.el addfile ./site-lisp/lj-custom.el addfile ./site-lisp/lj-fill.el addfile ./site-lisp/lj-login.el addfile ./site-lisp/lj-maint.el addfile ./site-lisp/lj-pcomplete.el addfile ./site-lisp/lj-protocol.el addfile ./site-lisp/lj-util.el addfile ./site-lisp/ljupdate.el addfile ./site-lisp/ssl.el adddir ./site-lisp/guileint-1.5 addfile ./site-lisp/guileint-1.5/COPYING addfile ./site-lisp/guileint-1.5/ChangeLog addfile ./site-lisp/guileint-1.5/INSTALL addfile ./site-lisp/guileint-1.5/README addfile ./site-lisp/guileint-1.5/TAGS addfile ./site-lisp/guileint-1.5/cmuscheme.el addfile ./site-lisp/guileint-1.5/comint.el addfile ./site-lisp/guileint-1.5/defmenu.el addfile ./site-lisp/guileint-1.5/fcreate.el addfile ./site-lisp/guileint-1.5/guess-mode.el addfile ./site-lisp/guileint-1.5/guile-init.el addfile ./site-lisp/guileint-1.5/guile.el addfile ./site-lisp/guileint-1.5/guileint.el addfile ./site-lisp/guileint-1.5/hilit-scheme.el addfile ./site-lisp/guileint-1.5/inda-c.el addfile ./site-lisp/guileint-1.5/inda-scheme.el addfile ./site-lisp/guileint-1.5/scheme.el addfile ./site-lisp/guileint-1.5/xscheme.el addfile ./init.d/frame.el addfile ./init.d/goodies.el addfile ./init.d/guileint.el addfile ./init.d/javascript.el addfile ./init.d/livejournal.el addfile ./init.d/midnight.el addfile ./init.d/misc.el addfile ./init.d/muse.el addfile ./init.d/slime.el addfile ./init.d/umbc.el addfile ./init.d/utf-8.el addfile ./dot-emacs addfile ./dot-emacs-local.el.template hunk ./dot-emacs 1 +;;; Clinton Ebadi's .emacs +;;; TODO: +;;; - Switch from guileint to guile-debugging +;;; - Make MMM work with html/css/javascript/php +;;; - Setup ERC + +;;; My lib dir +(defvar cke-site-emacs-dir (expand-file-name + "~/local/share/emacs")) + +(defvar cke-site-lisp-dir (concat cke-site-emacs-dir + "/site-lisp")) + +(add-to-list 'load-path cke-site-lisp-dir) + +;;; Local info files +(add-to-list 'Info-default-directory-list + (concat (getenv "HOME") "/local/share/info")) + +;;; Init Files +;; First load host specific config +(let ((site-config + (expand-file-name (concat "~/.emacs-" + "local" + ".el")))) + (if (file-exists-p site-config) + (load site-config))) + +;; Then load all of the elisp in init.d +(mapc #'(lambda (file-name) + (load file-name)) + (directory-files (concat cke-site-emacs-dir "/init.d") t ".*\\.el$")) + + +(custom-set-variables + ;; custom-set-variables was added by Custom -- don't edit or cut/paste it! + ;; Your init file should contain only one such instance. + '(auto-image-file-mode-hook nil) + '(browse-url-browser-function (quote (("/usr/share/doc/hyperspec/.*" . cke-browse-url-docs) (".*" . browse-url-galeon)))) + '(browse-url-generic-args nil) + '(browse-url-generic-program "galeon") + '(case-fold-search t) + '(clean-buffer-list-delay-general 5) + '(column-number-mode t) + '(completion-on-separator-character t) + '(confirm-kill-emacs (quote yes-or-no-p)) + '(current-language-environment "ASCII") + '(default-input-method (quote latin-1-postfix)) + '(desktop-enable t nil (desktop)) + '(global-font-lock-mode t nil (font-lock)) + '(gnus-fetch-old-headers t) + '(gnus-message-archive-group "INBOX.Sent") + '(gnus-message-archive-method (quote (nnimap "hcoop.net"))) + '(gnus-permanently-visible-groups "INBOX\\.inbox") + '(gnuserv-program (concat exec-directory "/gnuserv")) + '(iswitchb-default-method (quote samewindow)) + '(line-number-mode t) + '(lj-default-username "unknown_lamer") + '(lj-fill-function (quote ignore)) + '(mail-host-address "drizzlehell") + '(menu-bar-mode nil) + '(midnight-mode t nil (midnight)) + '(mouse-wheel-mode t nil (mwheel)) + '(muse-project-alist (quote (("unknownlamer.org" ("~/html/muse/src/unknownlamer.org" :default "index") (:base "lamer" :path "~/html/muse/site/unknownlamer.org"))))) + '(paren-mode (quote paren) nil (paren)) + '(save-completions-retention-time 1000) + '(save-place t nil (saveplace)) + '(scheme-program-name "guile") + '(show-paren-mode t nil (paren)) + '(text-mode-hook (quote (turn-on-auto-fill text-mode-hook-identify))) + '(todoo-initials "cke") + '(todoo-item-header-face (quote todoo-item-header-face)) + '(todoo-sub-item-header-face (quote todoo-sub-item-header-face)) + '(tool-bar-mode nil nil (tool-bar)) + '(truncate-partial-width-windows nil) + '(uniquify-buffer-name-style (quote post-forward-angle-brackets) nil (uniquify)) + '(user-mail-address "clinton@unknownlamer.org")) + +(custom-set-faces + ;; custom-set-faces was added by Custom -- don't edit or cut/paste it! + ;; Your init file should contain only one such instance. + '(default ((t (:stipple nil :background "#122e43" :foreground "#e3e3e3" :inverse-video nil :box nil :strike-through nil :overline nil :underline nil :slant normal :weight normal :height 90 :width normal :family "adobe-courier")))) + '(mmm-default-submode-face ((t (:background "#000000"))))) + +;;; Evil evil hack to make emacs have a readable background on the terminal +(if (not window-system) + (custom-set-faces + ;; custom-set-faces was added by Custom -- don't edit or cut/paste it! + ;; Your init file should contain only one such instance. + '(default ((t (:stipple nil :background "#000000" :foreground "#ffffff" :inverse-video nil :box nil :strike-through nil :overline nil :underline nil :slant normal :weight normal :height 90 :width normal :family "adobe-courier")))) + '(mmm-default-submode-face ((t (:background "#000000")))))) + +;;; Console Mode Enhancement +;(cond ((not window-system) +; (xterm-mouse-mode))) hunk ./dot-emacs-local.el.template 1 - +;;; Frames and Windows +(defvar cke-frame-height 70 + "Height of frames in my emacs") + +(defvar cke-initial-frame-width (* 86 2) + "Width of first emacs frame") hunk ./init.d/frame.el 1 - +;;; Frame config +(defvar cke-window-top-left nil + "Top left window of intial frame") + +(defvar cke-window-bottom-left nil + "Bottom left window of initial frame") + +;; Set up the initial frame +(cond ((eq window-system 'x) + (add-to-list 'initial-frame-alist + (cons 'height cke-frame-height)) + (add-to-list 'initial-frame-alist + (cons 'width cke-initial-frame-width)) + (split-window-horizontally) + (split-window-vertically) + (save-selected-window + (setq cke-window-top-left (selected-window)) + (other-window 1) + (setq cke-window-bottom-left (selected-window))))) + +;; Double height and split all new frames created manually +(global-set-key [?\C-x ?5 ?2] + #'(lambda () + (interactive) + (let ((f (make-frame))) + (cond ((eq (framep f) 'x) + (set-frame-height f cke-frame-height) + (split-window (frame-first-window f))) +g ((eq (framep f) 't) + (set-face-attribute 'default f + :background "black")))))) + +(winner-mode t) +(windmove-default-keybindings) + +;;; Special Windows +(defvar cke-window-html-docs cke-window-top-left + "Window that HTML documentation should be shown in") + +(defun cke-browse-url-docs (url new-session) + (save-selected-window + (select-window cke-window-html-docs) + (w3m-browse-url url new-session))) hunk ./init.d/goodies.el 1 - +;;; Emacs Goodies +(add-to-list 'load-path (expand-file-name + "/usr/share/emacs/site-lisp/emacs-goodies-el")) + +(require 'bar-cursor) +(bar-cursor-mode 1) +(iswitchb-mode) hunk ./init.d/guileint.el 1 - +;;; Guile (upgrade from guileint to guile-debugging when it builds +;;; again) +(setq scheme-program-name "/usr/bin/guile --emacs") +(add-to-list 'load-path (concat cke-site-lisp-dir "/guileint-1.5")) +(require 'guileint) hunk ./init.d/javascript.el 1 - +;;; Javascript +(load "javascript.el") +(autoload 'javascript-mode "javascript" nil t) +(add-to-list 'auto-mode-alist '("\\.js\\'" . javascript-mode)) hunk ./init.d/livejournal.el 1 - +;;; LiveJournal +(require 'ljupdate) +(setq lj-music-external-program "logjam-xmms-client") + +(add-hook 'lj-compose-init-headers-hook + #'(lambda () (insert "Music: " + (shell-command-to-string lj-music-external-program) + "\n"))) + +(add-hook 'lj-compose-init-headers-hook + #'(lambda () (insert "Picture: \n"))) hunk ./init.d/midnight.el 1 - +;;; Save the desktop every night just in case gnus + openssl decides +;;; to make emacs lock up +(add-hook 'midnight-hook + #'(lambda () (desktop-save (getenv "HOME")))) hunk ./init.d/misc.el 1 +;;; Small config stuff that doesn't fit anywhere else + +(put 'upcase-region 'disabled nil) +(global-set-key "\C-xg" 'goto-line) + +;; Server +(server-start) + +;; Make lambda look nicer +(defun pretty-lambdas () + (font-lock-add-keywords + nil `(("\\" + (0 (progn (compose-region (match-beginning 0) (match-end 0) + (make-char 'greek-iso8859-7 107)) + nil)))))) + +(add-hook 'emacs-lisp-mode-hook 'pretty-lambdas) +(add-hook 'scheme-mode-hook 'pretty-lambdas) +(add-hook 'lisp-mode-hook 'pretty-lambdas) + +(global-set-key [?\C-C ?o] #'switch-to-buffer-other-window) +(global-set-key [?\C-C ?.] #'find-tag) + +;;; M-\ was delete-horizontal-space +(global-set-key [?\M-\\ ] #'(lambda () (interactive) (insert "lambda"))) + + +(defun google-region (region-start region-end) + (interactive "r") + (browse-url (format "http://google.com/search?q=%s" + (buffer-substring-no-properties + region-start + region-end)))) + +(global-set-key [(control ?c) ?g] 'google-region) hunk ./init.d/muse.el 1 - +;;; Muse +(require 'muse-mode) +(require 'muse-project) +(require 'muse-html) hunk ./init.d/slime.el 1 - +;;; SLIME +(setq inferior-lisp-program "/usr/bin/sbcl") +(setq common-lisp-hyperspec-root "/usr/share/doc/hyperspec/") +(add-hook 'lisp-mode-hook 'slime-mode) hunk ./init.d/umbc.el 1 +;;; UMBC Bullshit +;; c-set-style to ellemetel if the source is in my UMBC homework +;; directory (since ellemtel is the devil and I refuse to code +;; anything that I don't have to in it) +(setq umbc-style-path-list + (list (expand-file-name + "~/homework/college/cmsc"))) + +(add-hook 'c-mode-hook + (lambda () + (dolist (path umbc-style-path-list) + (if (string-match path (buffer-file-name)) + (c-set-style "ellemtel"))))) + +(add-hook 'c++-mode-hook + (lambda () + (dolist (path umbc-style-path-list) + (if (string-match path (buffer-file-name)) + (c-set-style "ellemtel"))))) + hunk ./init.d/utf-8.el 1 - +;;; I am slowly converting to using UTF-8 for everything +(prefer-coding-system 'utf-8-unix) hunk ./site-lisp/guileint-1.5/COPYING 1 + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Library General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program 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 General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Library General +Public License instead of this License. hunk ./site-lisp/guileint-1.5/ChangeLog 1 +1999-08-23 Mikael Djurfeldt + + * guile.el (guile-frame-eval): Made interactive. + (guile-error-map): Added guile-frame-eval under "e". + +1999-03-17 Mikael Djurfeldt + + * guile.el (guile-file-readable-p, guile-find-file-noselect): New + functions. Sets buffer to scheme-buffer before doing there + action. + (guile-display-scheme-sexp): Use the above functions. + +1999-03-16 Mikael Djurfeldt + + * guile.el (guile-buffer-file-name): Version of buffer-file-name + which uses file-truename; + Use guile-buffer-file-name throughout. + +1999-03-15 Mikael Djurfeldt + + * guileint.el: Add conditional in order not to load the interface + multiple times. + + * guile.el (scheme-virtual-file-list-find): New function. Finds + an finfo entry using a file name. Uses `file-truename'; + Replaced all assoc calls with scheme-vertual-file-list-find + everywhere. + (guile-real-safe-backward-sexp): New function. Can skip backwards + over special scheme hash-syntax. + (guile-send-input): Use `guile-real-safe-backward-sexp'. + +1999-03-01 Mikael Djurfeldt + + * inda-scheme.el (scheme-electric-open-paren), + guile.el (guile-indent-or-complete): Use indent-for-tab-command + instead of scheme-indent-line. + + * scheme.el: Merge changes from Emacs-20.3. + +1998-06-18 Mikael Djurfeldt + + * guile.el (guile-send-region): Bugfix: Calculate new value for + start if overlays have been skipped. + (guile-send-overlay): Send define-module overlay to define the + module before sending any other overlay belonging to that module. + (guile-reparse-buffer): Detect define-module expressions. + +1998-06-14 Mikael Djurfeldt + + * guile.el (guile-select-stackframe): Increment line number. + +1998-06-10 Mikael Djurfeldt + + * guile.el: Removed calls to the former debugging function `cb'. + +1998-05-21 Mikael Djurfeldt + + * guile.el: Added nil nil t arguments in calls to make-overlay in + order to make the overlays rear-sticky. (This is an adaption to + Emacs-20.) + +1997-10-22 Mikael Djurfeldt + + * guile.el (guile-stack-frame-map): Need to be fset in Emacs-20. + +Wed Oct 1 22:02:19 1997 Mikael Djurfeldt + + * inda-scheme.el (inda-inferior-initializations): Disable + font-lock-mode in inferior-scheme buffers. (For some strange + reason, the inda-read-only-overlay modification hook gets called + when a character is inserted after the prompt if font-lock mode + has been activated.) + +Fri Aug 29 01:34:34 1997 Mikael Djurfeldt + + * guile.el (guile-display-name): Bugfix: filler --> + guile-define-filler. + (guile-send-overlay): Bugfix: Don't print "DEFINED" if start /= + overlay-start. + Added (require 'cl). + (guile-insert-before-prompt): Use guile-last-output-end + +Wed Aug 27 17:24:28 1997 Mikael Djurfeldt + + * guile.el (guile-complete-symbol): Bugfix: Don't do anything if + word is nil. + (guile-backtrace-in-source-window): New customization option. + (guile-display-error): Don't place backtrace in source window if + guile-backtrace-in-source-window is nil. + (guile-prep-backtrace): Set syntax-table to + scheme-mode-syntax-table. + +Tue Aug 26 00:01:01 1997 Mikael Djurfeldt + + * guile.el (guile-insert-before-prompt): Move the recenter code + here. + (guile-display-name): Use guile-insert-before-prompt. + +Mon Aug 25 22:46:23 1997 Mikael Djurfeldt + + * guile.el (guile-display-name): Recenter display if prompt + started at the beginning of the buffer, so that the first text + inserted before prompt will be visible. + +Mon Aug 25 19:36:50 1997 Mikael Djurfeldt + + * guile.el: New variable: guile-frame-overlay. + (guile-inferior-initialize): Initialize guile-frame-overlay to + nil. + (guile-place-frame-overlay, guile-turn-off-frame-overlay, + guile-unselect-stackframe): New functions. + (guile-unselect-stackframe): Turn off overlay and set + guile-selected-frame to nil. + (guile-stack-frame): New overlay category. + (guile-selected-frame): defun --> defvar + (guile-exit-debug): Turn off frame overlay. + (guile-prep-backtrace): Call `guile-unselect-stackframe'. + (guile-turn-off-sexp-overlay, guile-turn-off-frame-overlay): Check + (car args) before applying `delete-overlay'. + (guile-error-map): Bind S-mouse-2 to guile-frame-eval-at-click. + + * inda-scheme.el (inda-scheme-mode-initializations): Bind + S-mouse-2 to guile-frame-eval-at-click; Bind M-TAB to + guile-complete-symbol. + + * guile.el (guile-complete-symbol): Made a command. + (guile-frame-eval-at-click, guile-frame-eval): New functions. + Enables clicking on expressions in the source buffer to show their + values. + (guile-complete-symbol, guile-list-completions): Bugfix: Use + `buffer-name' instead of `current-buffer' in order to obtain the + buffer name. + (guile-select-frame): Always set guile-selected-frame. + +Mon Aug 25 16:21:18 1997 Mikael Djurfeldt + + * guile.el (guile-eval): Must wait for scheme-ready-p so that the + filter functions don't get called. + (guile-describe-variable): Put `guile-force-splittable' around + call to `with-output-to-temp-buffer' so that documentation can be + displayed also in *scheme* window even if it is dedicated. + +Sun Aug 24 22:19:16 1997 Mikael Djurfeldt + + * *** Transferred code to guile-emacs. *** + + * inda-scheme.el (inda-inferior-initializations): Removed + assignment to scheme-pop-to-buffer. + +Thu Aug 21 01:47:31 1997 Mikael Djurfeldt + + * guile.el (guile-eval-result, guile-receive-result, guile-eval): + guile-eval-result now contains the printed representation as a + string instead of an elisp object. + (guile-eval-output): New variable. + (guile-receive-result): Set guile-eval-output to + guile-unallowed-output. + (guile-define-startcol, guile-define-filler, + guile-define-fillcol): New variables. Buffer-local. + (guile-define-header-emitted-p): New variable. + (scheme-send-region): Print result of last sent overlay or show + message "Defined." if definitions have been made. + (guile-insert-before-prompt): Don't use guile-pre-prompt-marker. + (guile-pre-prompt-marker): New name: guile-define-name-marker. + (guile-send-region): Moved printing of defined names to + guile-display-name. + (guile-send-overlay): New parameters; Zeros guile-eval-output; + Adapted to new format of %%emacs-load; Can now send sub-parts of + an overlay; Use guile-display-name. + (guile-display-name): New function. + (guile-receive-result): Reset guile-unallowed-output after having + stored its value in guile-eval-output. + +Sat Aug 16 02:53:00 1997 Mikael Djurfeldt + + * guile.el (guile-display-error): Limit height of *Scheme Error* + window to half of guile-backtrace-max-height. + +Thu Jul 24 18:41:56 1997 Mikael Djurfeldt + + * guile.el (guile-normal-edit): Don't set + scheme-buffer-modified-p. This will be done by + guile-scheme-buffer-modified next time the buffer is modified. + (guile-scheme-buffer-modified): New function. + (guile-inferior-initialize): Make first-change-hook buffer-local, + add guile-scheme-modified; Pass t for initialp to + guile-enhanced-edit if the scheme-buffer seems untouched. + + * guile.el (guile-normal-edit): Unlink overlays and buffer. + + * inda-scheme.el (inda-send-definition, inda-mark-sexp): Make it + possible to send expressions to scheme just by clicking on them. + + * guileint.el: Removed statements that doesn't have anything to do + with the Guile interface per se (transient-mark-mode, iso-syntax + etc) + +Wed Jul 23 19:11:15 1997 Mikael Djurfeldt + + * inda-scheme.el: Changed inda menu --> interpret. + +Thu Jul 17 10:43:58 1997 Mikael Djurfeldt + + * inda96.el (devel-binary): Changed to unstable. + + * guile.el (guile-display-buffers): Check for window system before + deleting windows on buffer1. + (guile-get-create-error-window): Treat non-window system + differently. + (scheme-send-region): Don't check for (scheme-ready-p) here. This + is checked in guile-send-region. + (guile-send-region): Check for (scheme-ready-p) here instead. + Go to end-of-buffer before determining proper place for "DEFINED + %s (". + +Tue Oct 15 16:56:18 1996 Mikael Djurfeldt + + * Start of revision history for misc elisp files. + hunk ./site-lisp/guileint-1.5/INSTALL 1 +Requirements +============ + +* Emacs 21.2 + +* Guile 1.3 or higher, compiled with threads + +Installation instructions +========================= + +1. export SCHEME_PROGRAM_NAME= + + or + + Put + + (setq scheme-program-name " --emacs") + + in your ".emacs". + +2. Add this directory to your load path. + You can do this by adding + + (setq load-path (cons "" load-path)) + + to your .emacs. + +3. Put + + (require 'guileint) + + in your ".emacs". + +4. Activate Guile debugging by evaluating the following expressions + at the Guile prompt (or put them in your ".guile") + + (debug-enable 'debug) + (read-enable 'positions) hunk ./site-lisp/guileint-1.5/README 1 +Guile-Emacs interface +===================== + +This is version 1.5 of an Emacs interaction mode for running the Guile +Scheme interpreter. (The Guile side of the interface resides in +ice-9/emacs.scm.) + +It was originally part of a Guile-based course environment at KTH, +Stockholm. + +Disclaimer +---------- + +The core of this code was thrown together in a few days and was never +intended as more than a prototype. It has then evolved through +patching to quickly fix problems or adding new features and has for a +very long time been a playground for miscellaneous wild ideas. The +quality of the code reflects this. + +Features +-------- + +1. Automatic displaying (and highlighting) of erring expression in + source buffer. + +2. Tracking of source expressions in the source buffer so that + scheme:s view of source positions can be translated into actual + position which may be different due to recent editing in the + buffer. + +3. Errors and backtraces come up in separate buffers. (This keeps the + interaction buffer cleaner, and it's easier to see what you've + written before.) + +4. The part of the interaction buffer above the prompt line is write + protected. The motivation is to enforce a correct dialog history. + +5. Typing things in the interaction buffer while point is above the + prompt line moves point to prompt line. + +6. Previous expressions in the interaction buffer are clickable. + Clicking reenters the expression to the interpreter. Clicking + with shift copies the expression to the prompt line. + +7. Backtraces are clickable so that klicking on a certain frame + highlights the corresponding expression in the source buffer. + +8. Clicking on a variable in a backtrace displays it's value in + the echo area. + +9. The users input and the computers answer has different faces. + +10. Incomplete expressions in scheme buffers has a special face. + +11. Probably several more features which I haven't documented here + yet... + +Planned features +---------------- + +12. When single stepping through code, the current expression should + be highlighted in the source buffer. + +Short notes on how to run it +---------------------------- + +Choose "Guile" in the "Interpret" menu. + +Then you should get a scheme window with a running Guile. + +First try typing something erroneous. + +You should get an error + backtrace window. +You can exit this with `q' or ESC. + +Then try opening a scheme file, e. g. "foo.scm". +Type in something, e. g., + +(define (fac x) + (if (= x 0) + (koko) + (* x (fac (1- x))))) + +Choose "Eval buffer" from the menu, then type "(foo 3)" in +the scheme interpreter window. + +Your scheme buffer ("foo.scm") should now pop up, split into three +sections, and the expression "(koko)" should be marked in red. + +Again, typing `q' or ESC *in the error or backtrace window* will +remove these windows. + +Now try out the different items in the Scheme buffer "Scheme" menu. +If you go to the buffer "foo.scm" and select "Attach buffer" in the +menu, all changes to definitions in that buffer will be automagically +transfered to scheme. So, the illusion produced is that typing in the +"foo.scm" buffer is like typing into scheme memory. + +This illusion breaks down, however, if the scheme buffer contains +other stuff than procedure definitions... + +Code +---- + +The two main components are: + +* Code that can track positions of expressions in a source buffer + while editing. It maintains overlays over each top-level + expression, and can create new ones and delete old ones on the fly. + +* An extension to comint so that it gets a dispatching I/O multiplexer + similar to the one in xscheme.el. + +Most things are in "guile.el". + +Some setups + additional code is done by init-file-like files like +"guile-init.el". These are relics from the two first days of the +interface's life when it still had something reminiscent of +structure... ;-) + +Files with the same names as files in the Emacs distribution is slight +modifications of the correspondees. I originally planned to try +getting these included in Emacs. + +The following changes have been made to files from the Emacs distribution: + +cmuscheme.el: + +1. New buffer local variable: + + inferior-scheme-mode-line-process + +2. The variable + + scheme-buffer + +has been replaced by the buffer local variable + + inferior-scheme-associated-buffers + +3. mode-line-process has been changed to use + + inferior-scheme-mode-line-process + +comint.el: + +1. New buffer local variables: + + comint-unallowed-output-filter-functions + comint-output-filter-function + comint-allow-output-p + comint-dispatch-state + comint-string-accumulator + comint-string-receiver + comint-receiving-buffer + comint-buffer-receiver + +2. Patch to comint-exec + +Use comint-output-filter-function instead of comint-output-filter. + +3. Patch to comint-output-filter. + +4. New functions: + + comint-insert-output + comint-dispatch-filter-initialize + comint-dispatch-output-filter + +5. New variables: + + comint-dispatch-escape-character + comint-dispatch-string-end-regexp + comint-dispatch-buffer-end-regexp + comint-dispatch-alist + +Debugging +--------- + +If you do + + M-x guile-show-overlays + +in a scheme source buffer, the interface will show how it interprets +the expressions in the buffer (and how it tracks them, when they are +modified). + +Shut it off with + + M-x guile-hide-overlays + +I use *pairs* of colors for denoting each meaning. This is so that +you can distinguish adjacent overlays from eachother. + +Colors mean: + +dark/light blue: expressions are unmodified since last sent to Guile + +green/pink: expressions have been modified + +underlined: expressions are "broken" (which means that they can't be + sent to Guile) hunk ./site-lisp/guileint-1.5/TAGS 1 + +cmuscheme.el,1589 +(defvar inferior-scheme-mode-hook 76,3252 +(defvar inferior-scheme-mode-map 78,3339 +(define-key scheme-mode-map 91,3960 +(define-key scheme-mode-map 92,4038 +(define-key scheme-mode-map 93,4116 +(define-key scheme-mode-map 94,4180 +(define-key scheme-mode-map 95,4251 +(define-key scheme-mode-map 96,4311 +(define-key scheme-mode-map 97,4378 +(define-key scheme-mode-map 98,4445 +(define-key scheme-mode-map 99,4519 +(define-key scheme-mode-map 100,4577 +(define-key scheme-mode-map 101,4635 +(defvar inferior-scheme-mode-line-process 103,4714 +(defvar inferior-scheme-associated-buffers 105,4766 +(defun inferior-scheme-mode 107,4815 +(defvar inferior-scheme-filter-regexp 159,7186 +(defun scheme-input-filter 163,7386 +(defun scheme-get-old-input 167,7541 +(defun scheme-args-to-list 174,7713 +(defvar scheme-program-name 187,8135 +(defun run-scheme 191,8236 +(defun scheme-send-region 212,9148 +(defun scheme-send-definition 218,9357 +(defun scheme-send-last-sexp 227,9598 +(defvar scheme-compile-exp-command 232,9779 +(defun scheme-compile-region 235,9908 +(defun scheme-compile-definition 244,10277 +(defun switch-to-scheme 253,10527 +(defun scheme-send-region-and-go 264,10870 +(defun scheme-send-definition-and-go 271,11088 +(defun scheme-compile-definition-and-go 278,11288 +(defun scheme-compile-region-and-go 285,11497 +(defvar scheme-source-modes 292,11717 +(defvar scheme-prev-l/c-dir/file 298,12020 +(defun scheme-load-file 304,12242 +(defun scheme-compile-file 316,12833 +(defvar scheme-buffer 331,13449 +(defun scheme-proc 371,15465 +(defvar cmuscheme-load-hook 382,15798 + +comint.el,5691 +(defvar comint-prompt-regexp 142,6595 +(defvar comint-delimiter-argument-list 156,7036 +(defvar comint-input-autoexpand 167,7468 +(defvar comint-input-ignoredups 178,7907 +(defvar comint-input-ring-file-name 184,8091 +(defvar comint-scroll-to-bottom-on-input 190,8335 +(defvar comint-scroll-to-bottom-on-output 199,8667 +(defvar comint-scroll-show-maximum-output 210,9123 +(defvar comint-buffer-maximum-size 217,9436 +(defvar comint-input-ring-size 222,9687 +(defvar comint-process-echoes 225,9755 +(defvar comint-password-prompt-regexp232,9977 +(defvar comint-get-old-input 238,10248 +(defvar comint-dynamic-complete-functions245,10640 +(defvar comint-input-filter253,10950 +(defvar comint-input-filter-functions 259,11253 +(defvar comint-output-filter-function 265,11460 +(defvar comint-output-filter-functions 275,11889 +(defvar comint-allow-output-p 285,12404 +(defvar comint-unallowed-output-filter-functions 288,12495 +(defvar comint-dispatch-state 292,12650 +(defvar comint-string-accumulator 298,12906 +(defvar comint-string-receiver 301,13009 +(defvar comint-receiving-buffer 304,13106 +(defvar comint-buffer-receiver 306,13144 +(defvar comint-input-sender 308,13181 +(defvar comint-eol-on-send 315,13556 +(defvar comint-mode-hook 319,13679 +(defvar comint-exec-hook 323,13795 +(defvar comint-mode-map 330,14159 +(defvar comint-ptyp 332,14189 +(defvar comint-input-ring 336,14342 +(defvar comint-last-input-start)337,14373 +(defvar comint-last-input-end)338,14406 +(defvar comint-last-output-start)339,14437 +(defvar comint-input-ring-index 340,14471 +(defvar comint-matching-input-from-input-string 342,14551 +(defun comint-mode 358,15332 +(defun comint-check-proc 547,25194 +(defun make-comint 557,25639 +(defun comint-run 580,26817 +(defun comint-exec 591,27330 +(defun comint-exec-1 632,29080 +(defun comint-read-input-ring 678,31141 +(defun comint-write-input-ring 727,33024 +(defun comint-dynamic-list-input-ring 759,34253 +(defun comint-regexp-arg 789,35310 +(defun comint-search-arg 802,35800 +(defun comint-search-start 816,36214 +(defun comint-previous-input-string 827,36727 +(defun comint-previous-input 835,37027 +(defun comint-next-input 840,37171 +(defun comint-previous-matching-input-string 845,37301 +(defun comint-previous-matching-input-string-position 851,37600 +(defun comint-previous-matching-input 878,38797 +(defun comint-next-matching-input 896,39610 +(defun comint-previous-matching-input-from-input 904,40009 +(defun comint-next-matching-input-from-input 922,40777 +(defun comint-replace-by-expanded-history 931,41152 +(defun comint-replace-by-expanded-history-before-point 960,42382 +(defun comint-magic-space 1050,46141 +(defun comint-within-quotes 1057,46411 +(defun comint-how-many-region 1064,46740 +(defun comint-args 1074,47007 +(defun comint-delim-arg 1095,47922 +(defun comint-arguments 1114,48470 +(defun comint-send-input 1157,50012 +(defun comint-output-filter 1247,54099 +(defun comint-insert-output 1256,54398 +(defun comint-dispatch-filter-initialize 1292,55667 +(defun comint-dispatch-output-filter 1295,55750 +(defvar comint-dispatch-escape-character 1372,58218 +(defvar comint-dispatch-string-end-regexp 1376,58374 +(defvar comint-dispatch-buffer-end-regexp 1378,58428 +(defvar comint-dispatch-alist 1380,58482 +(defun comint-preinput-scroll-to-bottom 1395,59194 +(defun comint-postoutput-scroll-to-bottom 1423,60317 +(defun comint-truncate-buffer 1460,61719 +(defun comint-strip-ctrl-m 1470,62123 +(defalias 'shell-strip-ctrl-m 1480,62588 +(defun comint-show-maximum-output 1482,62641 +(defun comint-get-old-input-default 1488,62797 +(defun comint-copy-old-input 1499,63114 +(defun comint-skip-prompt 1510,63506 +(defun comint-after-pmark-p 1518,63830 +(defun comint-simple-send 1523,64033 +(defun comint-bol 1530,64291 +(defun comint-read-noecho 1545,64945 +(defun send-invisible 1595,66918 +(defun comint-watch-for-password-prompt 1608,67458 +(defalias 'comint-send-string 1620,67941 +(defalias 'comint-send-region 1621,67993 +(defun comint-kill-output 1625,68072 +(defun comint-show-output 1643,68715 +(defun comint-interrupt-subjob 1654,69103 +(defun comint-kill-subjob 1659,69227 +(defun comint-quit-subjob 1664,69351 +(defun comint-stop-subjob 1669,69475 +(defun comint-continue-subjob 1678,69851 +(defun comint-kill-input 1684,70053 +(defun comint-delchar-or-maybe-eof 1691,70310 +(defun comint-send-eof 1698,70511 +(defun comint-backward-matching-input 1704,70626 +(defun comint-forward-matching-input 1720,71273 +(defun comint-next-prompt 1729,71688 +(defun comint-previous-prompt 1738,71953 +(defun comint-source-default 1806,75313 +(defun comint-check-source 1823,76042 +(defun comint-extract-string 1856,77487 +(defun comint-get-source 1871,77980 +(defun comint-proc-query 1915,80009 +(defvar comint-completion-autolist 1958,81969 +(defvar comint-completion-addsuffix 1962,82127 +(defvar comint-completion-recexact 1968,82434 +(defvar comint-completion-fignore 1974,82666 +(defvar comint-file-name-prefix 1980,82891 +(defvar comint-file-name-chars1985,83102 +(defvar comint-file-name-quote-list 1993,83340 +(defun comint-directory 1999,83490 +(defun comint-word 2006,83728 +(defun comint-substitute-in-file-name 2024,84534 +(defun comint-match-partial-filename 2042,85229 +(defun comint-quote-filename 2050,85540 +(defun comint-unquote-filename 2063,86015 +(defun comint-dynamic-complete 2075,86372 +(defun comint-dynamic-complete-filename 2084,86712 +(defun comint-dynamic-complete-as-filename 2107,87759 +(defun comint-replace-by-expanded-filename 2161,90649 +(defun comint-dynamic-simple-complete 2174,91308 +(defun comint-dynamic-list-filename-completions 2225,93421 +(defun comint-dynamic-list-completions 2244,94324 + +defmenu.el,85 +(defun define-menu 38,1167 +(defun make-menu 57,1923 +(defun defmenu-gensym 88,3104 + +guess-mode.el,484 +(defvar guess-mode-load-hook 38,1175 +(defvar gm-check-contents-interval 43,1280 +(defvar gm-check-contents-maxsize 45,1320 +(defvar gm-check-contents-tick-limit 47,1361 +(defvar gm-check-modes 50,1461 +(defvar gm-guess-mode-alist52,1528 +(defun gm-check-contents-hook-function 57,1698 +(defun gm-check-contents 66,1992 +(defun gm-guess-mode 105,3229 +(defconst gm-extension-regexp-regexp120,3592 +(defun gm-make-extension-string 123,3685 +(defun gm-make-enumeration-string 138,4168 + +guile-init.el,612 +(defvar guile-init-load-hook 38,1100 +(defun inda-barf-at-modifications 46,1219 +(defun inda-boldify-previous-character 50,1342 +(defun inda-make-input-memory 56,1569 +(defun inda-reset-guile-last-output 66,2032 +(define-key inferior-scheme-mode-map 72,2231 +(define-key inferior-scheme-mode-map 73,2305 +(defun inda-mouse-yank-at-click 76,2427 +(defun inda-insert-input-memory 93,3188 +(defun inda-insert-input-memory-and-send 107,3665 +(defun inda-boldify 112,3792 +(defun inda-extend-read-only-overlay 115,3889 +(defun scheme-send-buffer 122,4082 +(defun indent-buffer 133,4384 +(defun indent-defun 142,4579 + +guile.el,8405 +(defvar guile-auto-attach 44,1469 +(defvar guile-load-hook 46,1501 +(defvar guile-error-face 57,1847 +(defvar guile-backtrace-mouse-face 60,1929 +(defvar guile-modified-face 63,2026 +(defvar guile-broken-face 66,2122 +(defvar guile-unmodified-face-1 71,2282 +(defvar guile-unmodified-face-2 72,2319 +(defvar guile-modified-face-1 73,2356 +(defvar guile-modified-face-2 74,2391 +(defvar guile-broken-face-1 75,2426 +(defvar guile-broken-face-2 76,2459 +(defvar guile-backtrace-in-source-window 81,2516 +(defvar guile-show-runlight-in-scheme-mode 85,2693 +(defvar guile-default-enhanced-edit 89,2881 +(defvar guile-popup-restart-on-death 92,2996 +(defvar guile-popup-restart-on-stop 94,3037 +(defvar guile-insert-reason 96,3077 +(defvar guile-kill-buffer-on-death 98,3109 +(defvar guile-process-timeout 100,3150 +(defconst guile-backtrace-buffer-name 103,3203 +(defconst guile-error-buffer-name 105,3264 +(defconst guile-backtrace-min-height 107,3317 +(defconst guile-backtrace-max-height 108,3358 +(defconst guile-backtrace-min-width 109,3399 +(defconst guile-backtrace-max-width 110,3439 +(defconst guile-symclash-obarray-size 165,5712 +(defconst guile-big-integer 167,5756 +(defvar guile-inferior-scheme-frame 172,5822 +(defun guile-inferior-initialize 176,5891 +(defvar default-handle-switch-frame-binding223,7682 +(define-key global-map 225,7768 +(defun guile-handle-switch-frame 227,7835 +(defun guile-sync-on-input 234,8060 +(defvar guile-unallowed-output 250,8563 +(defun guile-remember-unallowed-output 252,8600 +(defvar scheme-buffer-overlays 261,8854 +(defvar scheme-buffer-last-overlay 265,9030 +(defvar scheme-buffer-modified-p 269,9149 +(defvar scheme-buffer-overlays-modified-p 272,9261 +(defvar scheme-associated-process-buffer 274,9309 +(defvar scheme-overlay-repair-function 278,9480 +(defvar scheme-overlay-repair-idle-timer 282,9587 +(defun guile-scheme-mode-initialize 284,9634 +(defun guile-scheme-buffer-modified 307,10595 +(defun guile-scheme-mode-cleanup 310,10672 +(defun guile-clear-transcript 321,10961 +(defun guile-switch-to-scheme 336,11527 +(defvar scheme-ready-p 350,11961 +(defvar scheme-load-p 353,12062 +(defvar guile-no-stack-p 355,12090 +(defvar guile-no-source-p 357,12121 +(defun guile-inferior-dialog 359,12153 +(defun guile-sentinel 363,12279 +(defun guile-inferior-death-cleanup 394,13337 +(defun run-scheme 404,13704 +(defun guile-restart-scheme 428,14753 +(defun guile-shutdown 447,15323 +(defun guile-exit-scheme 473,16066 +(defun scheme:simple-action 494,16807 +(defun scheme:string-action 498,16902 +(defun scheme:buffer-action 503,17065 +(defun guile-no-stack 510,17289 +(defun guile-no-source 513,17344 +(defvar guile-eval-result 516,17401 +(defvar guile-eval-output 517,17432 +(defun guile-receive-result 519,17464 +(defun guile-eval 525,17658 +(defun scheme-set-runlight 542,18254 +(defconst scheme-runlight:running 557,18753 +(defconst scheme-runlight:input 560,18860 +(defconst scheme-runlight:read 563,18976 +(defconst scheme-runlight:load 566,19091 +(defvar guile-last-output-end)569,19204 +(defun scheme-enter-input-wait 572,19251 +(defun guile-on-error 594,19995 +(defun scheme-exit-input-wait 602,20225 +(defun scheme-enter-read 607,20364 +(defun scheme-enter-load 612,20497 +(defun scheme-load-acknowledge 617,20625 +(defvar guile-error-p 622,20726 +(defvar guile-last-displayed-position 624,20754 +(defvar guile-positional-reliability 626,20798 +(defvar guile-last-erring-overlay 628,20841 +(defvar guile-sexp-overlay 630,20881 +(defvar guile-frame-overlay 632,20914 +(defconst guile-position-regexp636,21049 +(defconst guile-position-regexp-line 639,21125 +(defconst guile-position-regexp-column 640,21165 +(defconst guile-position-regexp-filename 641,21207 +(defvar guile-error-width 643,21252 +(defvar guile-backtrace-length 644,21281 +(defvar guile-backtrace-width 645,21317 +(defvar guile-error-map 647,21351 +(defvar guile-stack-frame-map 660,21890 +(defun guile-exit-debug 671,22216 +(defun guile-receive-backtrace 682,22521 +(defun guile-prep-backtrace 695,22943 +(defvar guile-selected-frame 728,23954 +(defun guile-select-stackframe 730,23989 +(defun guile-unselect-stackframe 754,24901 +(defun guile-frame-eval 758,25006 +(defun guile-frame-eval-at-click 772,25519 +(defun guile-receive-error 781,25752 +(defvar guile-source-window 808,26619 +(defun guile-display-error 810,26653 +(defun guile-display-buffers 890,29326 +(defvar guile-error-frame 928,30625 +(defun guile-get-create-error-window 930,30657 +(defun guile-display-scheme-sexp 946,31248 +(defun guile-display-sexp 984,32718 +(defun guile-display-sexp-at-point 1013,33807 +(defun guile-place-frame-overlay 1047,34977 +(defun guile-turn-off-sexp-overlay 1054,35312 +(defun guile-turn-off-frame-overlay 1059,35500 +(defun guile-display-position 1064,35691 +(defun guile-goto-position 1082,36339 +(defun guile-get-file-buffer 1092,36622 +(defun guile-attachedp 1095,36693 +(defun guile-attach-buffer 1102,36866 +(defun guile-dont-attach-buffer 1137,38202 +(defun guile-detach-buffer 1171,39491 +(defun guile-detach-all 1193,40314 +(defvar scheme-virtual-file-list 1211,40948 +(defvar guile-synchronizedp 1213,40987 +(defvar guile-last-virtual-id 1215,41019 +(defun guile-synchronizedp 1217,41053 +(defun guile-alloc-virtual-id 1221,41117 +(defun guile-virtual-p 1228,41377 +(defun guile-virtually-linked-p 1231,41446 +(defun guile-virtual-link 1234,41527 +(defun scheme-virtual-unlink 1245,41862 +(defun guile-load-file 1251,42049 +(defun guile-reread-buffer 1276,43067 +(defun guile-get-associated-buffers 1290,43527 +(defvar guile-symclash-obarray 1295,43657 +(defun guile-reset-symclash-obarray 1297,43734 +(defvar guile-displayed-erring-buffers 1300,43833 +(defvar guile-quiet 1301,43877 +(defun guile-check-all 1303,43901 +(defun guile-check-all-1 1308,43990 +(defun guile-check-buffer 1331,44738 +(defun guile-show-check-error 1341,45012 +(defvar guile-last-displayed-erring-overlay 1360,45642 +(defun guile-check-buffer-1 1362,45692 +(defconst guile-defexpr 1372,45968 +(defconst guile-defexpr-name 1373,46058 +(defun guile-check-overlay 1375,46091 +(defun guile-sync-with-scheme 1401,46945 +(defun guile-sync-buffer 1422,47586 +(defun guile-sync-buffer-1 1427,47711 +(defun guile-alloc-finfo 1468,49219 +(defun guile-new-finfo 1486,49762 +(defvar guile-last-prompt-end 1497,50141 +(defvar guile-input-sent-p 1498,50176 +(defun guile-send-input 1500,50207 +(defconst guile-whitespace-chars 1520,50802 +(defun guile-whitespace-between-p 1522,50849 +(defun guile-send-changes 1534,51244 +(defun scheme-send-region 1557,51892 +(defvar guile-define-name-marker)1576,52541 +(defun guile-insert-before-prompt 1578,52576 +(defvar guile-define-header-emitted-p 1599,53223 +(defvar guile-define-startcol 1600,53266 +(defvar guile-define-filler 1601,53299 +(defvar guile-define-fillcol 1602,53331 +(defvar guile-last-result 1603,53363 +(defun guile-send-region 1605,53395 +(defconst guile-end-of-chunk 1635,54465 +(defun guile-send-overlay 1638,54530 +(defun guile-display-name 1725,57413 +(defvar guile-n-enhanced-buffers 1768,58741 +(defun guile-enhancedp 1771,58823 +(defun guile-get-enhanced-buffers 1779,59008 +(defun guile-enhanced-edit 1788,59217 +(defun guile-normal-edit 1804,59913 +(defun guile-current-line 1833,61028 +(defun guile-safe-forward-sexp 1837,61126 +(defun guile-safe-backward-sexp 1844,61303 +(defun guile-parse-buffer 1851,61482 +(defvar guile-tail-cons 1866,62063 +(defun guile-cons-before-match 1868,62104 +(defun guile-reparse-buffer 1882,62472 +(defvar guile-last-broken 2073,69132 +(defvar guile-repair-limit 2074,69163 +(defun guile-handle-modification 2076,69210 +(defun guile-repair-overlays 2100,70052 +(defun guile-backward-broken-sexp 2112,70437 +(defun rear-sticky-overlay-function 2132,70964 +(defvar guile-show-overlays-p 2139,71146 +(defun guile-show-overlays 2141,71182 +(defun guile-hide-overlays 2190,72670 +(defun guile-kill-overlays 2204,73043 +(defun overlay-kill 2217,73371 +(defun for-each 2221,73459 +(defconst guile-symbol-chars 2229,73568 +(defun guile-match-symnames 2231,73637 +(defmacro guile-force-splittable 2242,73905 +(defvar guile-complete-function 2258,74470 +(defun guile-indent-or-complete 2260,74529 +(defun guile-complete-symbol 2269,74780 +(defun guile-list-completions 2280,75124 +(defun guile-documentation-symbols 2295,75656 +(defun guile-variable-at-point 2300,75809 +(defun guile-describe-variable 2316,76346 + +guileint.el,187 +(defconst guileint-init-file 29,738 +(defvar guileint-emacs-dir 31,780 +(defvar guileint-default-load-path 40,1061 +(defun restore-blink-paren 104,3044 +(define-menu global-map 121,3371 + +hilit-scheme.el,0 + +inda-c.el,83 +(defvar inda-c-menu-fixed-p 44,1133 +(defun inda-c-mode-common-initialize 47,1196 + +inda-scheme.el,461 +(defun inda-scheme-mode-initializations 31,811 +(defun scheme-electric-open-paren 59,2234 +(defun scheme-close-paren 67,2456 +(defun inda-send-definition 75,2650 +(defun inda-mark-sexp 82,2846 +(defvar inda-read-only-overlay 87,2926 +(defun inda-inferior-initializations 89,2963 +(define-menu scheme-mode-map 159,5705 +(define-menu inferior-scheme-mode-map 188,6815 +(define-key inferior-scheme-mode-map 201,7427 +(define-key inferior-scheme-mode-map 202,7497 + +scheme.el,949 +(defvar scheme-mode-syntax-table 34,1231 +(defvar scheme-mode-abbrev-table 88,2829 +(define-abbrev-table 'scheme-mode-abbrev-table 89,2870 +(defvar scheme-mode-line-process 91,2922 +(defvar scheme-associated-process-buffer 93,2961 +(defun scheme-mode-variables 95,3008 +(defun scheme-mode-commands 126,4399 +(defvar scheme-mode-map 131,4584 +(defun scheme-mode 138,4764 +(defun scheme-mode-initialize 161,5636 +(defvar scheme-mit-dialect 166,5766 +(defun scheme-comment-indent 170,5910 +(defvar scheme-indent-offset 182,6260 +(defvar scheme-indent-function 183,6297 +(defun scheme-indent-line 185,6357 +(defun calculate-scheme-indent 220,7567 +(defun scheme-indent-function 306,11151 +(defvar scheme-body-indent 327,11995 +(defun scheme-indent-specform 329,12030 +(defun scheme-indent-defform 368,13634 +(defun would-be-symbol 378,13899 +(defun next-sexp-as-string 381,13983 +(defun scheme-let-indent 395,14449 +(defun scheme-indent-sexp 466,17752 + +xscheme.el,4262 +(defvar scheme-program-name 35,1122 +(defvar scheme-band-name 38,1211 +(defvar scheme-program-arguments 41,1288 +(defvar xscheme-allow-pipelined-evaluation 44,1400 +(defvar xscheme-startup-message49,1650 +(defvar xscheme-signal-death-message 59,2052 +(defun xscheme-evaluation-commands 62,2174 +(defun xscheme-interrupt-commands 70,2573 +(defun run-scheme 80,3044 +(defun reset-scheme 94,3517 +(defun xscheme-default-command-line 107,3994 +(defun scheme-interaction-mode 118,4266 +(defun scheme-interaction-mode-initialize 197,7776 +(defun scheme-interaction-mode-commands 202,7954 +(defvar scheme-interaction-mode-map 207,8181 +(defun xscheme-enter-interaction-mode 216,8582 +(defun scheme-debugger-mode 229,8973 +(defun scheme-debugger-mode-initialize 240,9376 +(defun scheme-debugger-mode-commands 245,9542 +(defvar scheme-debugger-mode-map 251,9740 +(defun scheme-debugger-self-insert 259,10056 +(defun xscheme-enter-debugger-mode 264,10203 +(defun xscheme-debugger-mode-p 273,10504 +(defun xscheme-send-string 282,10713 +(defun xscheme-send-string-1 299,11404 +(defun xscheme-send-string-2 305,11610 +(defun xscheme-yank-previous-send 311,11829 +(defun xscheme-select-process-buffer 317,11979 +(defun xscheme-send-region 328,12418 +(defun xscheme-send-definition 337,12760 +(defun xscheme-send-next-expression 351,13241 +(defun xscheme-send-previous-expression 357,13467 +(defun xscheme-send-current-line 363,13694 +(defun xscheme-send-buffer 377,14064 +(defun xscheme-send-char 384,14322 +(defun xscheme-send-breakpoint-interrupt 391,14522 +(defun xscheme-send-proceed 396,14670 +(defun xscheme-send-control-g-interrupt 401,14817 +(defun xscheme-send-control-u-interrupt 416,15330 +(defun xscheme-send-control-x-interrupt 421,15493 +(defun xscheme-send-interrupt 431,15906 +(defvar xscheme-process-command-line 441,16256 +(defvar xscheme-previous-send 444,16357 +(defvar xscheme-process-filter-state 447,16454 +(defvar xscheme-running-p 453,16715 +(defconst xscheme-control-g-synchronization-p 457,16875 +(defvar xscheme-control-g-disabled-p 462,17131 +(defvar xscheme-allow-output-p 466,17319 +(defvar xscheme-prompt 470,17466 +(defvar xscheme-string-accumulator 473,17532 +(defvar xscheme-string-receiver 476,17643 +(defvar xscheme-start-hook 479,17748 +(defvar xscheme-runlight-string 483,17920 +(defvar xscheme-mode-string 484,17957 +(defvar xscheme-filter-input 485,17990 +(defun xscheme-start-process 489,18054 +(defun xscheme-parse-command-line 517,19071 +(defun xscheme-wait-for-process 538,19595 +(defun xscheme-process-running-p 543,19694 +(defun xscheme-process-buffer 549,19892 +(defun xscheme-process-buffer-window 553,20013 +(defun xscheme-process-buffer-current-p 557,20143 +(defun xscheme-process-sentinel 563,20321 +(defun xscheme-process-filter-initialize 576,20768 +(defun xscheme-process-filter 584,21073 +(defun xscheme-process-filter-output 631,22872 +(defun xscheme-guarantee-newlines 649,23458 +(defun xscheme-goto-output-point 665,23811 +(defun xscheme-modeline-initialize 670,23973 +(defun xscheme-set-runlight 675,24156 +(defvar xscheme-process-filter-alist681,24301 +(defun xscheme-process-filter:simple-action 732,26282 +(defun xscheme-process-filter:string-action 736,26400 +(defconst xscheme-runlight:running 741,26588 +(defconst xscheme-runlight:input 744,26695 +(defconst xscheme-runlight:gc 747,26812 +(defun xscheme-start-gc 750,26924 +(defun xscheme-finish-gc 753,26998 +(defun xscheme-enter-input-wait 757,27127 +(defun xscheme-exit-input-wait 761,27243 +(defun xscheme-enable-control-g 765,27358 +(defun xscheme-display-process-buffer 768,27437 +(defun xscheme-unsolicited-read-char 777,27748 +(defun xscheme-eval 780,27797 +(defun xscheme-message 783,27869 +(defun xscheme-write-value 787,28001 +(defun xscheme-write-message-1 792,28195 +(defun xscheme-set-prompt-variable 802,28572 +(defun xscheme-set-prompt 805,28649 +(defun xscheme-output-goto 811,28839 +(defun xscheme-coerce-prompt 815,28934 +(defvar xscheme-prompt-alist826,29236 +(defun xscheme-cd 835,29595 +(defun xscheme-prompt-for-confirmation 840,29722 +(defun xscheme-prompt-for-expression 843,29837 +(defvar xscheme-prompt-for-expression-map 847,29996 +(defun xscheme-prompt-for-expression-exit 856,30319 +(defun xscheme-region-expression-p 862,30537 hunk ./site-lisp/guileint-1.5/cmuscheme.el 1 +;;; cmuscheme.el --- Scheme process in a buffer. Adapted from tea.el + +;; Copyright (C) 1988, 1994, 1997 Free Software Foundation, Inc. + +;; Author: Olin Shivers +;; Maintainer: FSF +;; Keywords: processes, lisp + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs 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 General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This is a customisation of comint-mode (see comint.el) +;; +;; Written by Olin Shivers (olin.shivers@cs.cmu.edu). With bits and pieces +;; lifted from scheme.el, shell.el, clisp.el, newclisp.el, cobol.el, et al.. +;; 8/88 +;; +;; Please send me bug reports, bug fixes, and extensions, so that I can +;; merge them into the master source. +;; +;; The changelog is at the end of this file. +;; +;; NOTE: MIT Cscheme, when invoked with the -emacs flag, has a special user +;; interface that communicates process state back to the superior emacs by +;; outputting special control sequences. The gnumacs package, xscheme.el, has +;; lots and lots of special purpose code to read these control sequences, and +;; so is very tightly integrated with the cscheme process. The cscheme +;; interrupt handler and debugger read single character commands in cbreak +;; mode; when this happens, xscheme.el switches to special keymaps that bind +;; the single letter command keys to emacs functions that directly send the +;; character to the scheme process. Cmuscheme mode does *not* provide this +;; functionality. If you are a cscheme user, you may prefer to use the +;; xscheme.el/cscheme -emacs interaction. +;; +;; Here's a summary of the pros and cons, as I see them. +;; xscheme: Tightly integrated with inferior cscheme process! A few commands +;; not in cmuscheme. But. Integration is a bit of a hack. Input +;; history only keeps the immediately prior input. Bizarre +;; keybindings. +;; +;; cmuscheme: Not tightly integrated with inferior cscheme process. But. +;; Carefully integrated functionality with the entire suite of +;; comint-derived CMU process modes. Keybindings reminiscent of +;; Zwei and Hemlock. Good input history. A few commands not in +;; xscheme. +;; +;; It's a tradeoff. Pay your money; take your choice. If you use a Scheme +;; that isn't Cscheme, of course, there isn't a choice. Xscheme.el is *very* +;; Cscheme-specific; you must use cmuscheme.el. Interested parties are +;; invited to port xscheme functionality on top of comint mode... + +;;; CHANGE LOG +;;; =========================================================================== +;;; 8/88 Olin +;;; Created. +;;; +;;; 2/15/89 Olin +;;; Removed -emacs flag from process invocation. It's only useful for +;;; cscheme, and makes cscheme assume it's running under xscheme.el, +;;; which messes things up royally. A bug. +;;; +;;; 5/22/90 Olin +;;; - Upgraded to use comint-send-string and comint-send-region. +;;; - run-scheme now offers to let you edit the command line if +;;; you invoke it with a prefix-arg. M-x scheme is redundant, and +;;; has been removed. +;;; - Explicit references to process "scheme" have been replaced with +;;; (scheme-proc). This allows better handling of multiple process bufs. +;;; - Added scheme-send-last-sexp, bound to C-x C-e. A gnu convention. +;;; - Have not added process query facility a la cmulisp.el's lisp-show-arglist +;;; and friends, but interested hackers might find a useful application +;;; of this facility. +;;; +;;; 3/12/90 Olin +;;; - scheme-load-file and scheme-compile-file no longer switch-to-scheme +;;; Tale suggested this. + +;;; Code: + +(require 'scheme) +(require 'comint) + + +(defgroup cmuscheme nil + "Run a scheme process in a buffer." + :group 'scheme) + +;;; INFERIOR SCHEME MODE STUFF +;;;============================================================================ + +(defcustom inferior-scheme-mode-hook nil + "*Hook for customising inferior-scheme mode." + :type 'hook + :group 'cmuscheme) + +(defvar inferior-scheme-mode-map + (let ((m (make-sparse-keymap))) + (define-key m "\M-\C-x" 'scheme-send-definition) ;gnu convention + (define-key m "\C-x\C-e" 'scheme-send-last-sexp) + (define-key m "\C-c\C-l" 'scheme-load-file) + (define-key m "\C-c\C-k" 'scheme-compile-file) + (scheme-mode-commands m) + m)) + +;; Install the process communication commands in the scheme-mode keymap. +(define-key scheme-mode-map "\M-\C-x" 'scheme-send-definition);gnu convention +(define-key scheme-mode-map "\C-x\C-e" 'scheme-send-last-sexp);gnu convention +(define-key scheme-mode-map "\C-c\C-e" 'scheme-send-definition) +(define-key scheme-mode-map "\C-c\M-e" 'scheme-send-definition-and-go) +(define-key scheme-mode-map "\C-c\C-r" 'scheme-send-region) +(define-key scheme-mode-map "\C-c\M-r" 'scheme-send-region-and-go) +(define-key scheme-mode-map "\C-c\M-c" 'scheme-compile-definition) +(define-key scheme-mode-map "\C-c\C-c" 'scheme-compile-definition-and-go) +(define-key scheme-mode-map "\C-c\C-z" 'switch-to-scheme) +(define-key scheme-mode-map "\C-c\C-l" 'scheme-load-file) +(define-key scheme-mode-map "\C-c\C-k" 'scheme-compile-file) ;k for "kompile" + +(let ((map (lookup-key scheme-mode-map [menu-bar scheme]))) + (define-key map [separator-eval] '("--")) + (define-key map [compile-file] + '("Compile Scheme File" . scheme-compile-file)) + (define-key map [load-file] + '("Load Scheme File" . scheme-load-file)) + (define-key map [switch] + '("Switch to Scheme" . switch-to-scheme)) + (define-key map [com-def-go] + '("Compile Definitiion & Go" . scheme-compile-definition-and-go)) + (define-key map [com-def] + '("Compile Definitiion" . scheme-compile-definition)) + (define-key map [send-def-go] + '("Evaluate Last Definition & Go" . scheme-send-definition-and-go)) + (define-key map [send-def] + '("Evaluate Last Definition" . scheme-send-definition)) + (define-key map [send-region-go] + '("Evaluate Region & Go" . scheme-send-region-and-go)) + (define-key map [send-region] + '("Evaluate Region" . scheme-send-region)) + (define-key map [send-sexp] + '("Evaluate Last S-expression" . scheme-send-last-sexp)) +) + +(defvar inferior-scheme-mode-line-process '("%s")) + +(defvar inferior-scheme-associated-buffers '()) + +(define-derived-mode inferior-scheme-mode comint-mode "Inferior Scheme" + "Major mode for interacting with an inferior Scheme process. + +The following commands are available: +\\{inferior-scheme-mode-map} + +A Scheme process can be fired up with M-x run-scheme. + +Customisation: Entry to this mode runs the hooks on comint-mode-hook and +inferior-scheme-mode-hook (in that order). + +You can send text to the inferior Scheme process from other buffers containing +Scheme source. + switch-to-scheme switches the current buffer to the Scheme process buffer. + scheme-send-definition sends the current definition to the Scheme process. + scheme-compile-definition compiles the current definition. + scheme-send-region sends the current region to the Scheme process. + scheme-compile-region compiles the current region. + + scheme-send-definition-and-go, scheme-compile-definition-and-go, + scheme-send-region-and-go, and scheme-compile-region-and-go + switch to the Scheme process buffer after sending their text. +For information on running multiple processes in multiple buffers, see +documentation for variable scheme-buffer. + +Commands: +Return after the end of the process' output sends the text from the + end of process to point. +Return before the end of the process' output copies the sexp ending at point + to the end of the process' output, and sends it. +Delete converts tabs to spaces as it moves back. +Tab indents for Scheme; with argument, shifts rest + of expression rigidly with the current line. +C-M-q does Tab on each line starting within following expression. +Paragraphs are separated only by blank lines. Semicolons start comments. +If you accidentally suspend your process, use \\[comint-continue-subjob] +to continue it." + ;; Customise in inferior-scheme-mode-hook + (setq comint-prompt-regexp "^[^>\n]*>+ *") ; OK for cscheme, oaklisp, T,... + (scheme-mode-variables) + (make-local-variable 'inferior-scheme-mode-line-process) + (make-local-variable 'inferior-scheme-associated-buffers) + (setq mode-line-process '(":" inferior-scheme-mode-line-process)) + (setq comint-input-filter (function scheme-input-filter)) + (setq comint-get-old-input (function scheme-get-old-input))) + +(defcustom inferior-scheme-filter-regexp "\\`\\s *\\S ?\\S ?\\s *\\'" + "*Input matching this regexp are not saved on the history list. +Defaults to a regexp ignoring all inputs of 0, 1, or 2 letters." + :type 'regexp + :group 'cmuscheme) + +(defun scheme-input-filter (str) + "Don't save anything matching `inferior-scheme-filter-regexp'." + (not (string-match inferior-scheme-filter-regexp str))) + +(defun scheme-get-old-input () + "Snarf the sexp ending at point." + (save-excursion + (let ((end (point))) + (backward-sexp) + (buffer-substring (point) end)))) + +(defun scheme-args-to-list (string) + (let ((where (string-match "[ \t]" string))) + (cond ((null where) (list string)) + ((not (= where 0)) + (cons (substring string 0 where) + (scheme-args-to-list (substring string (+ 1 where) + (length string))))) + (t (let ((pos (string-match "[^ \t]" string))) + (if (null pos) + nil + (scheme-args-to-list (substring string pos + (length string))))))))) + +;;;###autoload +(defun run-scheme (cmd) + "Run an inferior Scheme process, input and output via buffer *scheme*. +If there is a process already running in `*scheme*', switch to that buffer. +With argument, allows you to edit the command line (default is value +of `scheme-program-name'). Runs the hooks `inferior-scheme-mode-hook' +\(after the `comint-mode-hook' is run). +\(Type \\[describe-mode] in the process buffer for a list of commands.)" + + (interactive (list (if current-prefix-arg + (read-string "Run Scheme: " scheme-program-name) + scheme-program-name))) + (if (not (comint-check-proc "*scheme*")) + (let ((cmdlist (scheme-args-to-list cmd))) + (set-buffer (apply 'make-comint "scheme" (car cmdlist) + nil (cdr cmdlist))) + (inferior-scheme-mode))) + (setq scheme-program-name cmd) + (setq scheme-buffer "*scheme*") + (pop-to-buffer "*scheme*")) +;;;###autoload (add-hook 'same-window-buffer-names "*scheme*") + +(defun scheme-send-region (start end) + "Send the current region to the inferior Scheme process." + (interactive "r") + (comint-send-region (scheme-proc) start end) + (comint-send-string (scheme-proc) "\n")) + +(defun scheme-send-definition () + "Send the current definition to the inferior Scheme process." + (interactive) + (save-excursion + (end-of-defun) + (let ((end (point))) + (beginning-of-defun) + (scheme-send-region (point) end)))) + +(defun scheme-send-last-sexp () + "Send the previous sexp to the inferior Scheme process." + (interactive) + (scheme-send-region (save-excursion (backward-sexp) (point)) (point))) + +(defcustom scheme-compile-exp-command "(compile '%s)" + "*Template for issuing commands to compile arbitrary Scheme expressions." + :type 'string + :group 'cmuscheme) + +(defun scheme-compile-region (start end) + "Compile the current region in the inferior Scheme process. +\(A BEGIN is wrapped around the region: (BEGIN ))" + (interactive "r") + (comint-send-string (scheme-proc) (format scheme-compile-exp-command + (format "(begin %s)" + (buffer-substring start end)))) + (comint-send-string (scheme-proc) "\n")) + +(defun scheme-compile-definition () + "Compile the current definition in the inferior Scheme process." + (interactive) + (save-excursion + (end-of-defun) + (let ((end (point))) + (beginning-of-defun) + (scheme-compile-region (point) end)))) + +(defun switch-to-scheme (eob-p) + "Switch to the scheme process buffer. +With argument, position cursor at end of buffer." + (interactive "P") + (if (get-buffer scheme-buffer) + (pop-to-buffer scheme-buffer) + (error "No current process buffer. See variable `scheme-buffer'")) + (cond (eob-p + (push-mark) + (goto-char (point-max))))) + +(defun scheme-send-region-and-go (start end) + "Send the current region to the inferior Scheme process. +Then switch to the process buffer." + (interactive "r") + (scheme-send-region start end) + (switch-to-scheme t)) + +(defun scheme-send-definition-and-go () + "Send the current definition to the inferior Scheme. +Then switch to the process buffer." + (interactive) + (scheme-send-definition) + (switch-to-scheme t)) + +(defun scheme-compile-definition-and-go () + "Compile the current definition in the inferior Scheme. +Then switch to the process buffer." + (interactive) + (scheme-compile-definition) + (switch-to-scheme t)) + +(defun scheme-compile-region-and-go (start end) + "Compile the current region in the inferior Scheme. +Then switch to the process buffer." + (interactive "r") + (scheme-compile-region start end) + (switch-to-scheme t)) + +(defcustom scheme-source-modes '(scheme-mode) + "*Used to determine if a buffer contains Scheme source code. +If it's loaded into a buffer that is in one of these major modes, it's +considered a scheme source file by `scheme-load-file' and `scheme-compile-file'. +Used by these commands to determine defaults." + :type '(repeat function) + :group 'cmuscheme) + +(defvar scheme-prev-l/c-dir/file nil + "Caches the last (directory . file) pair. +Caches the last pair used in the last `scheme-load-file' or +`scheme-compile-file' command. Used for determining the default in the +next one.") + +(defun scheme-load-file (file-name) + "Load a Scheme file FILE-NAME into the inferior Scheme process." + (interactive (comint-get-source "Load Scheme file: " scheme-prev-l/c-dir/file + scheme-source-modes t)) ; T because LOAD + ; needs an exact name + (comint-check-source file-name) ; Check to see if buffer needs saved. + (setq scheme-prev-l/c-dir/file (cons (file-name-directory file-name) + (file-name-nondirectory file-name))) + (comint-send-string (scheme-proc) (concat "(load \"" + file-name + "\"\)\n"))) + +(defun scheme-compile-file (file-name) + "Compile a Scheme file FILE-NAME in the inferior Scheme process." + (interactive (comint-get-source "Compile Scheme file: " + scheme-prev-l/c-dir/file + scheme-source-modes + nil)) ; NIL because COMPILE doesn't + ; need an exact name. + (comint-check-source file-name) ; Check to see if buffer needs saved. + (setq scheme-prev-l/c-dir/file (cons (file-name-directory file-name) + (file-name-nondirectory file-name))) + (comint-send-string (scheme-proc) (concat "(compile-file \"" + file-name + "\"\)\n"))) + + +(defvar scheme-buffer nil "*The current scheme process buffer. + +MULTIPLE PROCESS SUPPORT +=========================================================================== +Cmuscheme.el supports, in a fairly simple fashion, running multiple Scheme +processes. To run multiple Scheme processes, you start the first up with +\\[run-scheme]. It will be in a buffer named *scheme*. Rename this buffer +with \\[rename-buffer]. You may now start up a new process with another +\\[run-scheme]. It will be in a new buffer, named *scheme*. You can +switch between the different process buffers with \\[switch-to-buffer]. + +Commands that send text from source buffers to Scheme processes -- +like `scheme-send-definition' or `scheme-compile-region' -- have to choose a +process to send to, when you have more than one Scheme process around. This +is determined by the global variable `scheme-buffer'. Suppose you +have three inferior Schemes running: + Buffer Process + foo scheme + bar scheme<2> + *scheme* scheme<3> +If you do a \\[scheme-send-definition-and-go] command on some Scheme source +code, what process do you send it to? + +- If you're in a process buffer (foo, bar, or *scheme*), + you send it to that process. +- If you're in some other buffer (e.g., a source file), you + send it to the process attached to buffer `scheme-buffer'. +This process selection is performed by function `scheme-proc'. + +Whenever \\[run-scheme] fires up a new process, it resets `scheme-buffer' +to be the new process's buffer. If you only run one process, this will +do the right thing. If you run multiple processes, you can change +`scheme-buffer' to another process buffer with \\[set-variable]. + +More sophisticated approaches are, of course, possible. If you find yourself +needing to switch back and forth between multiple processes frequently, +you may wish to consider ilisp.el, a larger, more sophisticated package +for running inferior Lisp and Scheme processes. The approach taken here is +for a minimal, simple implementation. Feel free to extend it.") + +(defun scheme-proc () + "Return the current scheme process. See variable `scheme-buffer'." + (let ((proc (get-buffer-process (if (eq major-mode 'inferior-scheme-mode) + (current-buffer) + scheme-buffer)))) + (or proc + (error "No current process. See variable `scheme-buffer'")))) + + +;;; Do the user's customisation... + +(defcustom cmuscheme-load-hook nil + "This hook is run when cmuscheme is loaded in. +This is a good place to put keybindings." + :type 'hook + :group 'cmuscheme) + +(run-hooks 'cmuscheme-load-hook) + +(provide 'cmuscheme) + +;;; cmuscheme.el ends here hunk ./site-lisp/guileint-1.5/comint.el 1 +;;; comint.el --- general command interpreter in a window stuff + +;; Copyright (C) 1988, 90, 92, 93, 94, 95, 96, 97, 98, 99, 2000, 2001 +;; Free Software Foundation, Inc. + +;; Author: Olin Shivers +;; Simon Marshall +;; Maintainer: FSF +;; Keywords: processes + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs 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 General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Please send me bug reports, bug fixes, and extensions, so that I can +;; merge them into the master source. +;; - Olin Shivers (shivers@cs.cmu.edu) +;; - Simon Marshall (simon@gnu.org) + +;; This file defines a general command-interpreter-in-a-buffer package +;; (comint mode). The idea is that you can build specific process-in-a-buffer +;; modes on top of comint mode -- e.g., lisp, shell, scheme, T, soar, .... +;; This way, all these specific packages share a common base functionality, +;; and a common set of bindings, which makes them easier to use (and +;; saves code, implementation time, etc., etc.). + +;; Several packages are already defined using comint mode: +;; - shell.el defines a shell-in-a-buffer mode. +;; - cmulisp.el defines a simple lisp-in-a-buffer mode. +;; +;; - The file cmuscheme.el defines a scheme-in-a-buffer mode. +;; - The file tea.el tunes scheme and inferior-scheme modes for T. +;; - The file soar.el tunes lisp and inferior-lisp modes for Soar. +;; - cmutex.el defines tex and latex modes that invoke tex, latex, bibtex, +;; previewers, and printers from within emacs. +;; - background.el allows csh-like job control inside emacs. +;; It is pretty easy to make new derived modes for other processes. + +;; For documentation on the functionality provided by comint mode, and +;; the hooks available for customising it, see the comments below. +;; For further information on the standard derived modes (shell, +;; inferior-lisp, inferior-scheme, ...), see the relevant source files. + +;; For hints on converting existing process modes (e.g., tex-mode, +;; background, dbx, gdb, kermit, prolog, telnet) to use comint-mode +;; instead of shell-mode, see the notes at the end of this file. + + +;; Brief Command Documentation: +;;============================================================================ +;; Comint Mode Commands: (common to all derived modes, like shell & cmulisp +;; mode) +;; +;; m-p comint-previous-input Cycle backwards in input history +;; m-n comint-next-input Cycle forwards +;; m-r comint-previous-matching-input Previous input matching a regexp +;; m-s comint-next-matching-input Next input that matches +;; m-c-l comint-show-output Show last batch of process output +;; return comint-send-input +;; c-d comint-delchar-or-maybe-eof Delete char unless at end of buff +;; c-c c-a comint-bol-or-process-mark First time, move point to bol; +;; second time, move to process-mark. +;; c-c c-u comint-kill-input ^u +;; c-c c-w backward-kill-word ^w +;; c-c c-c comint-interrupt-subjob ^c +;; c-c c-z comint-stop-subjob ^z +;; c-c c-\ comint-quit-subjob ^\ +;; c-c c-o comint-delete-output Delete last batch of process output +;; c-c c-r comint-show-output Show last batch of process output +;; c-c c-l comint-dynamic-list-input-ring List input history +;; +;; Not bound by default in comint-mode (some are in shell mode) +;; comint-run Run a program under comint-mode +;; send-invisible Read a line w/o echo, and send to proc +;; comint-dynamic-complete-filename Complete filename at point. +;; comint-dynamic-list-filename-completions List completions in help buffer. +;; comint-replace-by-expanded-filename Expand and complete filename at point; +;; replace with expanded/completed name. +;; comint-replace-by-expanded-history Expand history at point; +;; replace with expanded name. +;; comint-magic-space Expand history and add (a) space(s). +;; comint-kill-subjob No mercy. +;; comint-show-maximum-output Show as much output as possible. +;; comint-continue-subjob Send CONT signal to buffer's process +;; group. Useful if you accidentally +;; suspend your process (with C-c C-z). +;; comint-get-next-from-history Fetch successive input history lines +;; comint-accumulate Combine lines to send them together +;; as input. +;; comint-goto-process-mark Move point to where process-mark is. +;; comint-set-process-mark Set process-mark to point. + +;; comint-mode-hook is the comint mode hook. Basically for your keybindings. + +;;; Code: + +(require 'ring) + +;; Buffer Local Variables: +;;============================================================================ +;; Comint mode buffer local variables: +;; comint-prompt-regexp string comint-bol uses to match prompt +;; comint-delimiter-argument-list list For delimiters and arguments +;; comint-last-input-start marker Handy if inferior always echoes +;; comint-last-input-end marker For comint-delete-output command +;; comint-input-ring-size integer For the input history +;; comint-input-ring ring mechanism +;; comint-input-ring-index number ... +;; comint-save-input-ring-index number ... +;; comint-input-autoexpand symbol ... +;; comint-input-ignoredups boolean ... +;; comint-dynamic-complete-functions hook For the completion mechanism +;; comint-completion-fignore list ... +;; comint-file-name-chars string ... +;; comint-file-name-quote-list list ... +;; comint-get-old-input function Hooks for specific +;; comint-input-filter-functions hook process-in-a-buffer +;; comint-output-filter-functions hook function modes. +;; comint-unallowed-output-filter-functions hook +;; comint-preoutput-filter-functions hook +;; comint-input-filter function ... +;; comint-output-filter-function function ... +;; comint-input-sender function ... +;; comint-eol-on-send boolean ... +;; comint-process-echoes boolean ... +;; comint-scroll-to-bottom-on-input symbol For scroll behavior +;; comint-scroll-to-bottom-on-output symbol ... +;; comint-scroll-show-maximum-output boolean ... +;; comint-accum-marker maker For comint-accumulate +;; comint-last-output-overlay overlay +;; +;; Comint mode non-buffer local variables: +;; comint-completion-addsuffix boolean/cons For file name +;; comint-completion-autolist boolean completion behavior +;; comint-completion-recexact boolean ... + +(defgroup comint nil + "General command interpreter in a window stuff." + :group 'processes) + +(defgroup comint-completion nil + "Completion facilities in comint" + :group 'comint) + +(defgroup comint-source nil + "Source finding facilities in comint" + :prefix "comint-" + :group 'comint) + +(defvar comint-prompt-regexp "^" + "Regexp to recognise prompts in the inferior process. +Defaults to \"^\", the null string at BOL. + +This variable is only used if the variable +`comint-use-prompt-regexp-instead-of-fields' is non-nil. + +Good choices: + Canonical Lisp: \"^[^> \\n]*>+:? *\" (Lucid, franz, kcl, T, cscheme, oaklisp) + Lucid Common Lisp: \"^\\\\(>\\\\|\\\\(->\\\\)+\\\\) *\" + franz: \"^\\\\(->\\\\|<[0-9]*>:\\\\) *\" + kcl: \"^>+ *\" + shell: \"^[^#$%>\\n]*[#$%>] *\" + T: \"^>+ *\" + +This is a good thing to set in mode hooks.") + +(defvar comint-delimiter-argument-list () + "List of characters to recognise as separate arguments in input. +Strings comprising a character in this list will separate the arguments +surrounding them, and also be regarded as arguments in their own right (unlike +whitespace). See `comint-arguments'. +Defaults to the empty list. + +For shells, a good value is (?\\| ?& ?< ?> ?\\( ?\\) ?;). + +This is a good thing to set in mode hooks.") + +(defcustom comint-input-autoexpand nil + "*If non-nil, expand input command history references on completion. +This mirrors the optional behavior of tcsh (its autoexpand and histlit). + +If the value is `input', then the expansion is seen on input. +If the value is `history', then the expansion is only when inserting +into the buffer's input ring. See also `comint-magic-space' and +`comint-dynamic-complete'. + +This variable is buffer-local." + :type '(choice (const :tag "off" nil) + (const input) + (const history) + (other :tag "on" t)) + :group 'comint) + +(defcustom comint-highlight-input t + "*If non-nil, highlight input; also allow choosing previous input with a mouse. +The face used is `comint-highlight-input'." + :type 'boolean + :group 'comint) + +(defface comint-highlight-input '((t (:bold t))) + "Face to use to highlight input when `comint-highlight-input' is non-nil." + :group 'comint) + +(defcustom comint-highlight-prompt t + "*If non-nil, highlight program prompts. +The face used is `comint-highlight-prompt'." + :type 'boolean + :group 'comint) + +(defface comint-highlight-prompt + '((((background dark)) (:foreground "cyan")) + (t (:foreground "dark blue"))) + "Face to use to highlight prompt when `comint-highlight-prompt' is non-nil." + :group 'comint) + +(defcustom comint-input-ignoredups nil + "*If non-nil, don't add input matching the last on the input ring. +This mirrors the optional behavior of bash. + +This variable is buffer-local." + :type 'boolean + :group 'comint) + +(defcustom comint-input-ring-file-name nil + "*If non-nil, name of the file to read/write input history. +See also `comint-read-input-ring' and `comint-write-input-ring'. + +This variable is buffer-local, and is a good thing to set in mode hooks." + :type '(choice (const :tag "nil" nil) + file) + :group 'comint) + +(defcustom comint-scroll-to-bottom-on-input nil + "*Controls whether input to interpreter causes window to scroll. +If nil, then do not scroll. If t or `all', scroll all windows showing buffer. +If `this', scroll only the selected window. + +The default is nil. + +See `comint-preinput-scroll-to-bottom'. This variable is buffer-local." + :type '(choice (const :tag "off" nil) + (const t) + (const all) + (const this)) + :group 'comint) + +(defcustom comint-scroll-to-bottom-on-output nil + "*Controls whether interpreter output causes window to scroll. +If nil, then do not scroll. If t or `all', scroll all windows showing buffer. +If `this', scroll only the selected window. +If `others', scroll only those that are not the selected window. + +The default is nil. + +See variable `comint-scroll-show-maximum-output' and function +`comint-postoutput-scroll-to-bottom'. This variable is buffer-local." + :type '(choice (const :tag "off" nil) + (const t) + (const all) + (const this) + (const others)) + :group 'comint) + +(defcustom comint-scroll-show-maximum-output nil + "*Controls how interpreter output causes window to scroll. +If non-nil, then show the maximum output when the window is scrolled. + +See variable `comint-scroll-to-bottom-on-output' and function +`comint-postoutput-scroll-to-bottom'. This variable is buffer-local." + :type 'boolean + :group 'comint) + +(defcustom comint-buffer-maximum-size 1024 + "*The maximum size in lines for comint buffers. +Comint buffers are truncated from the top to be no greater than this number, if +the function `comint-truncate-buffer' is on `comint-output-filter-functions'." + :type 'integer + :group 'comint) + +(defvar comint-input-ring-size 32 + "Size of input history ring.") + +(defvar comint-input-ring-separator "\n" + "Separator between commands in the history file.") + +(defvar comint-input-history-ignore "^#" + "Regexp for history entries that should be ignored when comint initializes.") + +(defcustom comint-process-echoes nil + "*If non-nil, assume that the subprocess echoes any input. +If so, delete one copy of the input so that only one copy eventually +appears in the buffer. + +This variable is buffer-local." + :type 'boolean + :group 'comint) + +;; AIX puts the name of the person being su'd to in front of the prompt. +;; kinit prints a prompt like `Password for devnull@GNU.ORG: '. +;; ksu prints a prompt like `Kerberos password for devnull/root@GNU.ORG: '. +;; ssh-add prints a prompt like `Enter passphrase: '. +;; Some implementations of passwd use "Password (again)" as the 2nd prompt. +(defcustom comint-password-prompt-regexp + "\\(\\([Oo]ld \\|[Nn]ew \\|Kerberos \\|'s \\|login \\|CVS \\|^\\)\ +[Pp]assword\\( (again)\\)?\\|pass phrase\\|Enter passphrase\\)\ +\\( for [^@ \t\n]+@[^@ \t\n]+\\)?:\\s *\\'" + "*Regexp matching prompts for passwords in the inferior process. +This is used by `comint-watch-for-password-prompt'." + :type 'regexp + :group 'comint) + +;; Here are the per-interpreter hooks. +(defvar comint-get-old-input (function comint-get-old-input-default) + "Function that returns old text in comint mode. +This function is called when return is typed while the point is in old +text. It returns the text to be submitted as process input. The +default is `comint-get-old-input-default', which either grabs the +current input field or grabs the current line and strips off leading +text matching `comint-prompt-regexp', depending on the value of +`comint-use-prompt-regexp-instead-of-fields'.") + +(defvar comint-dynamic-complete-functions + '(comint-replace-by-expanded-history comint-dynamic-complete-filename) + "List of functions called to perform completion. +Functions should return non-nil if completion was performed. +See also `comint-dynamic-complete'. + +This is a good thing to set in mode hooks.") + +(defvar comint-input-filter + (function (lambda (str) (not (string-match "\\`\\s *\\'" str)))) + "Predicate for filtering additions to input history. +Takes one argument, the input. If non-nil, the input may be saved on the input +history list. Default is to save anything that isn't all whitespace.") + +(defvar comint-input-filter-functions '() + "Functions to call before input is sent to the process. +These functions get one argument, a string containing the text to send. + +This variable is buffer-local.") + +(defvar comint-output-filter-function 'comint-output-filter + "Selects which process output filter to use. +It's normal value is `comint-output-filter' but if you want your process +to control emacs via a one-character protocol as in xscheme, set it to +`comint-dispatch-output-filter' and describe your protocol using the +variables `comint-dispatch-escape-character' and +`comint-dispatch-alist'. + +This variable is buffer-local.") + +(defvar comint-output-filter-functions '(comint-postoutput-scroll-to-bottom) + "Functions to call after output is inserted into the buffer. +One possible function is `comint-postoutput-scroll-to-bottom'. +These functions get one argument, a string containing the text as originally +inserted. Note that this might not be the same as the buffer contents between +`comint-last-output-start' and the buffer's `process-mark', if other filter +functions have already modified the buffer. + +See also `comint-preoutput-filter-functions'. + +This variable is buffer-local.") + +(defvar comint-allow-output-p t + "Setting this varible to nil inhibits process output.") + +(defvar comint-unallowed-output-filter-functions '() + "Functions to call with output which the process generates while +`comint-allow-output-p' is nil.") + +(defvar comint-dispatch-state 'idle + "State of scheme process escape reader state machine: +idle waiting for an escape sequence +reading-type received an escape character but nothing else +reading-string reading string") + +(defvar comint-string-accumulator "" + "Accumulator for the string being received from the process.") + +(defvar comint-string-receiver nil + "Procedure to send the string argument from the process.") + +(defvar comint-receiving-buffer nil) + +(defvar comint-buffer-receiver nil) + +(defvar comint-input-sender (function comint-simple-send) + "Function to actually send to PROCESS the STRING submitted by user. +Usually this is just `comint-simple-send', but if your mode needs to +massage the input string, put a different function here. +`comint-simple-send' just sends the string plus a newline. +This is called from the user command `comint-send-input'.") + +(defcustom comint-eol-on-send t + "*Non-nil means go to the end of the line before sending input. +See `comint-send-input'." + :type 'boolean + :group 'comint) + +;; Note: If it is decided to purge comint-prompt-regexp from the source +;; entirely, searching for uses of this variable will help to identify +;; places that need attention. +(defcustom comint-use-prompt-regexp-instead-of-fields nil + "*If non-nil, use `comint-prompt-regexp' to distinguish prompts from user-input. +If nil, then program output and user-input are given different `field' +properties, which emacs commands can use to distinguish them (in +particular, common movement commands such as begining-of-line respect +field boundaries in a natural way)." + :type 'boolean + :group 'comint) + +(defcustom comint-mode-hook '() + "Called upon entry into `comint-mode' +This is run before the process is cranked up." + :type 'hook + :group 'comint) + +(defcustom comint-exec-hook '() + "Called each time a process is exec'd by `comint-exec'. +This is called after the process is cranked up. It is useful for things that +must be done each time a process is executed in a comint mode buffer (e.g., +`(process-kill-without-query)'). In contrast, the `comint-mode-hook' is only +executed once when the buffer is created." + :type 'hook + :group 'comint) + +(defvar comint-mode-map nil) + +(defvar comint-ptyp t + "Non-nil if communications via pty; false if by pipe. Buffer local. +This is to work around a bug in Emacs process signaling.") + +(defvar comint-input-ring nil) +(defvar comint-last-input-start) +(defvar comint-last-input-end) +(defvar comint-last-output-start) +(defvar comint-input-ring-index nil + "Index of last matched history element.") +(defvar comint-matching-input-from-input-string "" + "Input previously used to match input history.") +(defvar comint-save-input-ring-index + "Last input ring index which you copied. +This is to support the command \\[comint-get-next-from-history].") + +(defvar comint-accum-marker nil + "Non-nil if you are accumulating input lines to send as input together. +The command \\[comint-accumulate] sets this.") + +(put 'comint-replace-by-expanded-history 'menu-enable 'comint-input-autoexpand) +(put 'comint-input-ring 'permanent-local t) +(put 'comint-input-ring-index 'permanent-local t) +(put 'comint-save-input-ring-index 'permanent-local t) +(put 'comint-input-autoexpand 'permanent-local t) +(put 'comint-input-filter-functions 'permanent-local t) +(put 'comint-output-filter-function 'permanent-local t) +(put 'comint-output-filter-functions 'permanent-local t) +(put 'comint-unallowed-output-filter-functions 'permanent-local t) +(put 'comint-preoutput-filter-functions 'permanent-local t) +(put 'comint-scroll-to-bottom-on-input 'permanent-local t) +(put 'comint-scroll-to-bottom-on-output 'permanent-local t) +(put 'comint-scroll-show-maximum-output 'permanent-local t) +(put 'comint-ptyp 'permanent-local t) + +(put 'comint-mode 'mode-class 'special) + +(define-derived-mode comint-mode fundamental-mode "Comint" + "Major mode for interacting with an inferior interpreter. +Interpreter name is same as buffer name, sans the asterisks. +Return at end of buffer sends line as input. +Return not at end copies rest of line to end and sends it. +Setting variable `comint-eol-on-send' means jump to the end of the line +before submitting new input. + +This mode is customised to create major modes such as Inferior Lisp +mode, Shell mode, etc. This can be done by setting the hooks +`comint-input-filter-functions', `comint-input-filter', `comint-input-sender' +and `comint-get-old-input' to appropriate functions, and the variable +`comint-prompt-regexp' to the appropriate regular expression. + +An input history is maintained of size `comint-input-ring-size', and +can be accessed with the commands \\[comint-next-input], \\[comint-previous-input], and \\[comint-dynamic-list-input-ring]. +Input ring history expansion can be achieved with the commands +\\[comint-replace-by-expanded-history] or \\[comint-magic-space]. +Input ring expansion is controlled by the variable `comint-input-autoexpand', +and addition is controlled by the variable `comint-input-ignoredups'. + +Commands with no default key bindings include `send-invisible', +`comint-dynamic-complete', `comint-dynamic-list-filename-completions', and +`comint-magic-space'. + +Input to, and output from, the subprocess can cause the window to scroll to +the end of the buffer. See variables `comint-output-filter-functions', +`comint-preoutput-filter-functions', `comint-scroll-to-bottom-on-input', +and `comint-scroll-to-bottom-on-output'. + +If you accidentally suspend your process, use \\[comint-continue-subjob] +to continue it. + +\\{comint-mode-map} + +Entry to this mode runs the hooks on `comint-mode-hook'." + (setq mode-line-process '(":%s")) + (make-local-variable 'comint-last-input-start) + (setq comint-last-input-start (make-marker)) + (set-marker comint-last-input-start (point-min)) + (make-local-variable 'comint-last-input-end) + (setq comint-last-input-end (make-marker)) + (set-marker comint-last-input-end (point-min)) + (make-local-variable 'comint-last-output-start) + (setq comint-last-output-start (make-marker)) + (make-local-variable 'comint-last-output-overlay) + (make-local-variable 'comint-last-prompt-overlay) + (make-local-variable 'comint-prompt-regexp) ; Don't set; default + (make-local-variable 'comint-input-ring-size) ; ...to global val. + (make-local-variable 'comint-input-ring) + (make-local-variable 'comint-input-ring-file-name) + (or (and (boundp 'comint-input-ring) comint-input-ring) + (setq comint-input-ring (make-ring comint-input-ring-size))) + (make-local-variable 'comint-input-ring-index) + (make-local-variable 'comint-save-input-ring-index) + (or (and (boundp 'comint-input-ring-index) comint-input-ring-index) + (setq comint-input-ring-index nil)) + (or (and (boundp 'comint-save-input-ring-index) comint-save-input-ring-index) + (setq comint-save-input-ring-index nil)) + (make-local-variable 'comint-matching-input-from-input-string) + (make-local-variable 'comint-input-autoexpand) + (make-local-variable 'comint-input-ignoredups) + (make-local-variable 'comint-delimiter-argument-list) + (make-local-hook 'comint-dynamic-complete-functions) + (make-local-variable 'comint-completion-fignore) + (make-local-variable 'comint-get-old-input) + (make-local-hook 'comint-input-filter-functions) + (make-local-variable 'comint-input-filter) + (make-local-variable 'comint-input-sender) + (make-local-variable 'comint-eol-on-send) + (make-local-variable 'comint-scroll-to-bottom-on-input) + (make-local-variable 'comint-scroll-to-bottom-on-output) + (make-local-variable 'comint-scroll-show-maximum-output) + (add-hook 'pre-command-hook 'comint-preinput-scroll-to-bottom t t) + (make-local-variable 'comint-output-filter-function) + (make-local-variable 'comint-allow-output-p) + (make-local-variable 'comint-dispatch-state) + (make-local-variable 'comint-string-accumulator) + (make-local-variable 'comint-string-receiver) + (make-local-variable 'comint-receiving-buffer) + (make-local-variable 'comint-buffer-receiver) + (make-local-hook 'comint-output-filter-functions) + (make-local-hook 'comint-unallowed-output-filter-functions) + (make-local-hook 'comint-exec-hook) + (make-local-variable 'comint-ptyp) + (make-local-variable 'comint-process-echoes) + (make-local-variable 'comint-file-name-chars) + (make-local-variable 'comint-file-name-quote-list) + (make-local-variable 'comint-accum-marker) + (setq comint-accum-marker (make-marker)) + (set-marker comint-accum-marker nil) + ;; This behavior is not useful in comint buffers, and is annoying + (set (make-local-variable 'next-line-add-newlines) nil)) + +(if comint-mode-map + nil + ;; Keys: + (setq comint-mode-map (make-sparse-keymap)) + (define-key comint-mode-map "\ep" 'comint-previous-input) + (define-key comint-mode-map "\en" 'comint-next-input) + (define-key comint-mode-map [C-up] 'comint-previous-input) + (define-key comint-mode-map [C-down] 'comint-next-input) + (define-key comint-mode-map "\er" 'comint-previous-matching-input) + (define-key comint-mode-map "\es" 'comint-next-matching-input) + (define-key comint-mode-map [?\C-c ?\M-r] 'comint-previous-matching-input-from-input) + (define-key comint-mode-map [?\C-c ?\M-s] 'comint-next-matching-input-from-input) + (define-key comint-mode-map "\e\C-l" 'comint-show-output) + (define-key comint-mode-map "\C-m" 'comint-send-input) + (define-key comint-mode-map "\C-d" 'comint-delchar-or-maybe-eof) + (define-key comint-mode-map "\C-c " 'comint-accumulate) + (define-key comint-mode-map "\C-c\C-x" 'comint-get-next-from-history) + (define-key comint-mode-map "\C-c\C-a" 'comint-bol-or-process-mark) + (define-key comint-mode-map "\C-c\C-u" 'comint-kill-input) + (define-key comint-mode-map "\C-c\C-w" 'backward-kill-word) + (define-key comint-mode-map "\C-c\C-c" 'comint-interrupt-subjob) + (define-key comint-mode-map "\C-c\C-z" 'comint-stop-subjob) + (define-key comint-mode-map "\C-c\C-\\" 'comint-quit-subjob) + (define-key comint-mode-map "\C-c\C-m" 'comint-copy-old-input) + (define-key comint-mode-map "\C-c\C-o" 'comint-delete-output) + (define-key comint-mode-map "\C-c\C-r" 'comint-show-output) + (define-key comint-mode-map "\C-c\C-e" 'comint-show-maximum-output) + (define-key comint-mode-map "\C-c\C-l" 'comint-dynamic-list-input-ring) + (define-key comint-mode-map "\C-c\C-n" 'comint-next-prompt) + (define-key comint-mode-map "\C-c\C-p" 'comint-previous-prompt) + (define-key comint-mode-map "\C-c\C-d" 'comint-send-eof) + (define-key comint-mode-map "\C-c\C-s" 'comint-write-output) + ;; Mouse Buttons: + (define-key comint-mode-map [mouse-2] 'comint-insert-clicked-input) + ;; Menu bars: + ;; completion: + (define-key comint-mode-map [menu-bar completion] + (cons "Complete" (make-sparse-keymap "Complete"))) + (define-key comint-mode-map [menu-bar completion complete-expand] + '("Expand File Name" . comint-replace-by-expanded-filename)) + (define-key comint-mode-map [menu-bar completion complete-listing] + '("File Completion Listing" . comint-dynamic-list-filename-completions)) + (define-key comint-mode-map [menu-bar completion complete-file] + '("Complete File Name" . comint-dynamic-complete-filename)) + (define-key comint-mode-map [menu-bar completion complete] + '("Complete Before Point" . comint-dynamic-complete)) + ;; Input history: + (define-key comint-mode-map [menu-bar inout] + (cons "In/Out" (make-sparse-keymap "In/Out"))) + (define-key comint-mode-map [menu-bar inout delete-output] + '("Delete Current Output Group" . comint-delete-output)) + (define-key comint-mode-map [menu-bar inout append-output-to-file] + '("Append Current Output Group to File" . comint-append-output-to-file)) + (define-key comint-mode-map [menu-bar inout write-output] + '("Write Current Output Group to File" . comint-write-output)) + (define-key comint-mode-map [menu-bar inout next-prompt] + '("Forward Output Group" . comint-next-prompt)) + (define-key comint-mode-map [menu-bar inout previous-prompt] + '("Backward Output Group" . comint-previous-prompt)) + (define-key comint-mode-map [menu-bar inout show-maximum-output] + '("Show Maximum Output" . comint-show-maximum-output)) + (define-key comint-mode-map [menu-bar inout show-output] + '("Show Current Output Group" . comint-show-output)) + (define-key comint-mode-map [menu-bar inout kill-input] + '("Kill Current Input" . comint-kill-input)) + (define-key comint-mode-map [menu-bar inout copy-input] + '("Copy Old Input" . comint-copy-old-input)) + (define-key comint-mode-map [menu-bar inout forward-matching-history] + '("Forward Matching Input..." . comint-forward-matching-input)) + (define-key comint-mode-map [menu-bar inout backward-matching-history] + '("Backward Matching Input..." . comint-backward-matching-input)) + (define-key comint-mode-map [menu-bar inout next-matching-history] + '("Next Matching Input..." . comint-next-matching-input)) + (define-key comint-mode-map [menu-bar inout previous-matching-history] + '("Previous Matching Input..." . comint-previous-matching-input)) + (define-key comint-mode-map [menu-bar inout next-matching-history-from-input] + '("Next Matching Current Input" . comint-next-matching-input-from-input)) + (define-key comint-mode-map [menu-bar inout previous-matching-history-from-input] + '("Previous Matching Current Input" . comint-previous-matching-input-from-input)) + (define-key comint-mode-map [menu-bar inout next-history] + '("Next Input" . comint-next-input)) + (define-key comint-mode-map [menu-bar inout previous-history] + '("Previous Input" . comint-previous-input)) + (define-key comint-mode-map [menu-bar inout list-history] + '("List Input History" . comint-dynamic-list-input-ring)) + (define-key comint-mode-map [menu-bar inout expand-history] + '("Expand History Before Point" . comint-replace-by-expanded-history)) + ;; Signals + (define-key comint-mode-map [menu-bar signals] + (cons "Signals" (make-sparse-keymap "Signals"))) + (define-key comint-mode-map [menu-bar signals eof] + '("EOF" . comint-send-eof)) + (define-key comint-mode-map [menu-bar signals kill] + '("KILL" . comint-kill-subjob)) + (define-key comint-mode-map [menu-bar signals quit] + '("QUIT" . comint-quit-subjob)) + (define-key comint-mode-map [menu-bar signals cont] + '("CONT" . comint-continue-subjob)) + (define-key comint-mode-map [menu-bar signals stop] + '("STOP" . comint-stop-subjob)) + (define-key comint-mode-map [menu-bar signals break] + '("BREAK" . comint-interrupt-subjob)) + ;; Put them in the menu bar: + (setq menu-bar-final-items (append '(completion inout signals) + menu-bar-final-items)) + ) + +(defun comint-check-proc (buffer) + "Return t if there is a living process associated w/buffer BUFFER. +Living means the status is `open', `run', or `stop'. +BUFFER can be either a buffer or the name of one." + (let ((proc (get-buffer-process buffer))) + (and proc (memq (process-status proc) '(open run stop))))) + +;;;###autoload +(defun make-comint-in-buffer (name buffer program &optional startfile &rest switches) + "Make a comint process NAME in BUFFER, running PROGRAM. +If BUFFER is nil, it defaults to NAME surrounded by `*'s. +PROGRAM should be either a string denoting an executable program to create +via `start-process', or a cons pair of the form (HOST . SERVICE) denoting a TCP +connection to be opened via `open-network-stream'. If there is already a +running process in that buffer, it is not restarted. Optional third arg +STARTFILE is the name of a file to send the contents of to the process. + +If PROGRAM is a string, any more args are arguments to PROGRAM." + (or (fboundp 'start-process) + (error "Multi-processing is not supported for this system")) + (setq buffer (get-buffer-create (or buffer (concat "*" name "*")))) + ;; If no process, or nuked process, crank up a new one and put buffer in + ;; comint mode. Otherwise, leave buffer and existing process alone. + (unless (comint-check-proc buffer) + (with-current-buffer buffer + (comint-mode)) ; Install local vars, mode, keymap, ... + (comint-exec buffer name program startfile switches)) + buffer) + +;;;###autoload +(defun make-comint (name program &optional startfile &rest switches) + "Make a comint process NAME in a buffer, running PROGRAM. +The name of the buffer is made by surrounding NAME with `*'s. +PROGRAM should be either a string denoting an executable program to create +via `start-process', or a cons pair of the form (HOST . SERVICE) denoting a TCP +connection to be opened via `open-network-stream'. If there is already a +running process in that buffer, it is not restarted. Optional third arg +STARTFILE is the name of a file to send the contents of to the process. + +If PROGRAM is a string, any more args are arguments to PROGRAM." + (apply #'make-comint-in-buffer name nil program startfile switches)) + +;;;###autoload +(defun comint-run (program) + "Run PROGRAM in a comint buffer and switch to it. +The buffer name is made by surrounding the file name of PROGRAM with `*'s. +The file name is used to make a symbol name, such as `comint-sh-hook', and any +hooks on this symbol are run in the buffer. +See `make-comint' and `comint-exec'." + (interactive "sRun program: ") + (let ((name (file-name-nondirectory program))) + (switch-to-buffer (make-comint name program)) + (run-hooks (intern-soft (concat "comint-" name "-hook"))))) + +(defun comint-exec (buffer name command startfile switches) + "Start up a process in buffer BUFFER for comint modes. +Blasts any old process running in the buffer. Doesn't set the buffer mode. +You can use this to cheaply run a series of processes in the same comint +buffer. The hook `comint-exec-hook' is run after each exec." + (save-excursion + (set-buffer buffer) + (let ((proc (get-buffer-process buffer))) ; Blast any old process. + (if proc (delete-process proc))) + ;; Crank up a new process + (let ((proc + (if (consp command) + (open-network-stream name buffer (car command) (cdr command)) + (comint-exec-1 name buffer command switches)))) + (set-process-filter proc comint-output-filter-function) + (let ((init-fn (get 'comint-output-filter-function 'initialize))) + (and init-fn (funcall init-fn))) + (make-local-variable 'comint-ptyp) + (setq comint-ptyp process-connection-type) ; T if pty, NIL if pipe. + ;; Jump to the end, and set the process mark. + (goto-char (point-max)) + (set-marker (process-mark proc) (point)) + ;; Feed it the startfile. + (cond (startfile + ;;This is guaranteed to wait long enough + ;;but has bad results if the comint does not prompt at all + ;; (while (= size (buffer-size)) + ;; (sleep-for 1)) + ;;I hope 1 second is enough! + (sleep-for 1) + (goto-char (point-max)) + (insert-file-contents startfile) + (setq startfile (buffer-substring (point) (point-max))) + (delete-region (point) (point-max)) + (comint-send-string proc startfile))) + (run-hooks 'comint-exec-hook) + buffer))) + +;; This auxiliary function cranks up the process for comint-exec in +;; the appropriate environment. + +(defun comint-exec-1 (name buffer command switches) + (let ((process-environment + (nconc + ;; If using termcap, we specify `emacs' as the terminal type + ;; because that lets us specify a width. + ;; If using terminfo, we specify `dumb' because that is + ;; a defined terminal type. `emacs' is not a defined terminal type + ;; and there is no way for us to define it here. + ;; Some programs that use terminfo get very confused + ;; if TERM is not a valid terminal type. + (if (and (boundp 'system-uses-terminfo) system-uses-terminfo) + (list "TERM=dumb" "TERMCAP=" + (format "COLUMNS=%d" (window-width))) + (list "TERM=emacs" + (format "TERMCAP=emacs:co#%d:tc=unknown:" (window-width)))) + (if (getenv "EMACS") nil (list "EMACS=t")) + process-environment)) + (default-directory + (if (file-accessible-directory-p default-directory) + default-directory + (char-to-string directory-sep-char))) + proc decoding encoding changed) + (let ((exec-path (if (file-name-directory command) + ;; If the command has slashes, make sure we + ;; first look relative to the current directory. + (cons default-directory exec-path) exec-path))) + (setq proc (apply 'start-process name buffer command switches))) + (let ((coding-systems (process-coding-system proc))) + (setq decoding (car coding-systems) + encoding (cdr coding-systems))) + ;; If start-process decided to use some coding system for decoding + ;; data sent from the process and the coding system doesn't + ;; specify EOL conversion, we had better convert CRLF to LF. + (if (vectorp (coding-system-eol-type decoding)) + (setq decoding (coding-system-change-eol-conversion decoding 'dos) + changed t)) + ;; Even if start-process left the coding system for encoding data + ;; sent from the process undecided, we had better use the same one + ;; as what we use for decoding. But, we should suppress EOL + ;; conversion. + (if (and decoding (not encoding)) + (setq encoding (coding-system-change-eol-conversion decoding 'unix) + changed t)) + (if changed + (set-process-coding-system proc decoding encoding)) + proc)) + + +(defun comint-insert-clicked-input (event) + "In a comint buffer, set the current input to the clicked-on previous input." + (interactive "e") + (let ((over (catch 'found + ;; Ignore non-input overlays + (dolist (ov (overlays-at (posn-point (event-end event)))) + (when (eq (overlay-get ov 'field) 'input) + (throw 'found ov)))))) + ;; Do we have input in this area? + (if over + (let ((input-str (buffer-substring (overlay-start over) + (overlay-end over)))) + (goto-char (point-max)) + (delete-region + ;; Can't use kill-region as it sets this-command + (or (marker-position comint-accum-marker) + (process-mark (get-buffer-process (current-buffer)))) + (point)) + (insert input-str)) + ;; Fall back to the global definition. + (let* ((keys (this-command-keys)) + (last-key (and (vectorp keys) (aref keys (1- (length keys))))) + (fun (and last-key (lookup-key global-map (vector last-key))))) + (if fun (call-interactively fun)))))) + + +;; Input history processing in a buffer +;; =========================================================================== +;; Useful input history functions, courtesy of the Ergo group. + +;; Eleven commands: +;; comint-dynamic-list-input-ring List history in help buffer. +;; comint-previous-input Previous input... +;; comint-previous-matching-input ...matching a string. +;; comint-previous-matching-input-from-input ... matching the current input. +;; comint-next-input Next input... +;; comint-next-matching-input ...matching a string. +;; comint-next-matching-input-from-input ... matching the current input. +;; comint-backward-matching-input Backwards input... +;; comint-forward-matching-input ...matching a string. +;; comint-replace-by-expanded-history Expand history at point; +;; replace with expanded history. +;; comint-magic-space Expand history and insert space. +;; +;; Three functions: +;; comint-read-input-ring Read into comint-input-ring... +;; comint-write-input-ring Write to comint-input-ring-file-name. +;; comint-replace-by-expanded-history-before-point Workhorse function. + +(defun comint-read-input-ring (&optional silent) + "Sets the buffer's `comint-input-ring' from a history file. +The name of the file is given by the variable `comint-input-ring-file-name'. +The history ring is of size `comint-input-ring-size', regardless of file size. +If `comint-input-ring-file-name' is nil this function does nothing. + +If the optional argument SILENT is non-nil, we say nothing about a +failure to read the history file. + +This function is useful for major mode commands and mode hooks. + +The commands stored in the history file are separated by the +`comint-input-ring-separator', and entries that match +`comint-input-history-ignore' are ignored. The most recent command +comes last. + +See also `comint-input-ignoredups' and `comint-write-input-ring'." + (cond ((or (null comint-input-ring-file-name) + (equal comint-input-ring-file-name "")) + nil) + ((not (file-readable-p comint-input-ring-file-name)) + (or silent + (message "Cannot read history file %s" + comint-input-ring-file-name))) + (t + (let* ((history-buf (get-buffer-create " *temp*")) + (file comint-input-ring-file-name) + (count 0) + (size comint-input-ring-size) + (ring (make-ring size))) + (unwind-protect + (save-excursion + (set-buffer history-buf) + (widen) + (erase-buffer) + (insert-file-contents file) + ;; Save restriction in case file is already visited... + ;; Watch for those date stamps in history files! + (goto-char (point-max)) + (let (start end history) + (while (and (< count comint-input-ring-size) + (re-search-backward comint-input-ring-separator nil t) + (setq end (match-beginning 0))) + (if (re-search-backward comint-input-ring-separator nil t) + (setq start (match-end 0)) + (setq start (point-min))) + (setq history (buffer-substring start end)) + (goto-char start) + (if (and (not (string-match comint-input-history-ignore history)) + (or (null comint-input-ignoredups) + (ring-empty-p ring) + (not (string-equal (ring-ref ring 0) history)))) + (progn + (ring-insert-at-beginning ring history) + (setq count (1+ count))))))) + (kill-buffer history-buf)) + (setq comint-input-ring ring + comint-input-ring-index nil))))) + +(defun comint-write-input-ring () + "Writes the buffer's `comint-input-ring' to a history file. +The name of the file is given by the variable `comint-input-ring-file-name'. +The original contents of the file are lost if `comint-input-ring' is not empty. +If `comint-input-ring-file-name' is nil this function does nothing. + +Useful within process sentinels. + +See also `comint-read-input-ring'." + (cond ((or (null comint-input-ring-file-name) + (equal comint-input-ring-file-name "") + (null comint-input-ring) (ring-empty-p comint-input-ring)) + nil) + ((not (file-writable-p comint-input-ring-file-name)) + (message "Cannot write history file %s" comint-input-ring-file-name)) + (t + (let* ((history-buf (get-buffer-create " *Temp Input History*")) + (ring comint-input-ring) + (file comint-input-ring-file-name) + (index (ring-length ring))) + ;; Write it all out into a buffer first. Much faster, but messier, + ;; than writing it one line at a time. + (save-excursion + (set-buffer history-buf) + (erase-buffer) + (while (> index 0) + (setq index (1- index)) + (insert (ring-ref ring index) comint-input-ring-separator)) + (write-region (buffer-string) nil file nil 'no-message) + (kill-buffer nil)))))) + + +(defun comint-dynamic-list-input-ring () + "List in help buffer the buffer's input history." + (interactive) + (if (or (not (ring-p comint-input-ring)) + (ring-empty-p comint-input-ring)) + (message "No history") + (let ((history nil) + (history-buffer " *Input History*") + (index (1- (ring-length comint-input-ring))) + (conf (current-window-configuration))) + ;; We have to build up a list ourselves from the ring vector. + (while (>= index 0) + (setq history (cons (ring-ref comint-input-ring index) history) + index (1- index))) + ;; Change "completion" to "history reference" + ;; to make the display accurate. + (with-output-to-temp-buffer history-buffer + (display-completion-list history) + (set-buffer history-buffer) + (forward-line 3) + (while (search-backward "completion" nil 'move) + (replace-match "history reference"))) + (sit-for 0) + (message "Hit space to flush") + (let ((ch (read-event))) + (if (eq ch ?\ ) + (set-window-configuration conf) + (setq unread-command-events (list ch))))))) + + +(defun comint-regexp-arg (prompt) + ;; Return list of regexp and prefix arg using PROMPT. + (let* (;; Don't clobber this. + (last-command last-command) + (regexp (read-from-minibuffer prompt nil nil nil + 'minibuffer-history-search-history))) + (list (if (string-equal regexp "") + (setcar minibuffer-history-search-history + (nth 1 minibuffer-history-search-history)) + regexp) + (prefix-numeric-value current-prefix-arg)))) + +(defun comint-search-arg (arg) + ;; First make sure there is a ring and that we are after the process mark + (cond ((not (comint-after-pmark-p)) + (error "Not at command line")) + ((or (null comint-input-ring) + (ring-empty-p comint-input-ring)) + (error "Empty input ring")) + ((zerop arg) + ;; arg of zero resets search from beginning, and uses arg of 1 + (setq comint-input-ring-index nil) + 1) + (t + arg))) + +(defun comint-search-start (arg) + ;; Index to start a directional search, starting at comint-input-ring-index + (if comint-input-ring-index + ;; If a search is running, offset by 1 in direction of arg + (mod (+ comint-input-ring-index (if (> arg 0) 1 -1)) + (ring-length comint-input-ring)) + ;; For a new search, start from beginning or end, as appropriate + (if (>= arg 0) + 0 ; First elt for forward search + (1- (ring-length comint-input-ring))))) ; Last elt for backward search + +(defun comint-previous-input-string (arg) + "Return the string ARG places along the input ring. +Moves relative to `comint-input-ring-index'." + (ring-ref comint-input-ring (if comint-input-ring-index + (mod (+ arg comint-input-ring-index) + (ring-length comint-input-ring)) + arg))) + +(defun comint-previous-input (arg) + "Cycle backwards through input history." + (interactive "*p") + (comint-previous-matching-input "." arg)) + +(defun comint-next-input (arg) + "Cycle forwards through input history." + (interactive "*p") + (comint-previous-input (- arg))) + +(defun comint-previous-matching-input-string (regexp arg) + "Return the string matching REGEXP ARG places along the input ring. +Moves relative to `comint-input-ring-index'." + (let* ((pos (comint-previous-matching-input-string-position regexp arg))) + (if pos (ring-ref comint-input-ring pos)))) + +(defun comint-previous-matching-input-string-position (regexp arg &optional start) + "Return the index matching REGEXP ARG places along the input ring. +Moves relative to START, or `comint-input-ring-index'." + (if (or (not (ring-p comint-input-ring)) + (ring-empty-p comint-input-ring)) + (error "No history")) + (let* ((len (ring-length comint-input-ring)) + (motion (if (> arg 0) 1 -1)) + (n (mod (- (or start (comint-search-start arg)) motion) len)) + (tried-each-ring-item nil) + (prev nil)) + ;; Do the whole search as many times as the argument says. + (while (and (/= arg 0) (not tried-each-ring-item)) + ;; Step once. + (setq prev n + n (mod (+ n motion) len)) + ;; If we haven't reached a match, step some more. + (while (and (< n len) (not tried-each-ring-item) + (not (string-match regexp (ring-ref comint-input-ring n)))) + (setq n (mod (+ n motion) len) + ;; If we have gone all the way around in this search. + tried-each-ring-item (= n prev))) + (setq arg (if (> arg 0) (1- arg) (1+ arg)))) + ;; Now that we know which ring element to use, if we found it, return that. + (if (string-match regexp (ring-ref comint-input-ring n)) + n))) + +(defun comint-previous-matching-input (regexp arg) + "Search backwards through input history for match for REGEXP. +\(Previous history elements are earlier commands.) +With prefix argument N, search for Nth previous match. +If N is negative, find the next or Nth next match." + (interactive (comint-regexp-arg "Previous input matching (regexp): ")) + (setq arg (comint-search-arg arg)) + (let ((pos (comint-previous-matching-input-string-position regexp arg))) + ;; Has a match been found? + (if (null pos) + (error "Not found") + (setq comint-input-ring-index pos) + (message "History item: %d" (1+ pos)) + (delete-region + ;; Can't use kill-region as it sets this-command + (or (marker-position comint-accum-marker) + (process-mark (get-buffer-process (current-buffer)))) + (point)) + (insert (ring-ref comint-input-ring pos))))) + +(defun comint-next-matching-input (regexp arg) + "Search forwards through input history for match for REGEXP. +\(Later history elements are more recent commands.) +With prefix argument N, search for Nth following match. +If N is negative, find the previous or Nth previous match." + (interactive (comint-regexp-arg "Next input matching (regexp): ")) + (comint-previous-matching-input regexp (- arg))) + +(defun comint-previous-matching-input-from-input (arg) + "Search backwards through input history for match for current input. +\(Previous history elements are earlier commands.) +With prefix argument N, search for Nth previous match. +If N is negative, search forwards for the -Nth following match." + (interactive "p") + (if (not (memq last-command '(comint-previous-matching-input-from-input + comint-next-matching-input-from-input))) + ;; Starting a new search + (setq comint-matching-input-from-input-string + (buffer-substring + (or (marker-position comint-accum-marker) + (process-mark (get-buffer-process (current-buffer)))) + (point)) + comint-input-ring-index nil)) + (comint-previous-matching-input + (concat "^" (regexp-quote comint-matching-input-from-input-string)) + arg)) + +(defun comint-next-matching-input-from-input (arg) + "Search forwards through input history for match for current input. +\(Following history elements are more recent commands.) +With prefix argument N, search for Nth following match. +If N is negative, search backwards for the -Nth previous match." + (interactive "p") + (comint-previous-matching-input-from-input (- arg))) + + +(defun comint-replace-by-expanded-history (&optional silent start) + "Expand input command history references before point. +Expansion is dependent on the value of `comint-input-autoexpand'. + +This function depends on the buffer's idea of the input history, which may not +match the command interpreter's idea, assuming it has one. + +Assumes history syntax is like typical Un*x shells'. However, since emacs +cannot know the interpreter's idea of input line numbers, assuming it has one, +it cannot expand absolute input line number references. + +If the optional argument SILENT is non-nil, never complain +even if history reference seems erroneous. + +If the optional argument START is non-nil, that specifies the +start of the text to scan for history references, rather +than the logical beginning of line. + +See `comint-magic-space' and `comint-replace-by-expanded-history-before-point'. + +Returns t if successful." + (interactive) + (if (and comint-input-autoexpand + (if comint-use-prompt-regexp-instead-of-fields + ;; Use comint-prompt-regexp + (save-excursion + (beginning-of-line) + (looking-at (concat comint-prompt-regexp "!\\|\\^"))) + ;; Use input fields. User input that hasn't been entered + ;; yet, at the end of the buffer, has a nil `field' property. + (and (null (get-char-property (point) 'field)) + (string-match "!\\|^\\^" (field-string))))) + ;; Looks like there might be history references in the command. + (let ((previous-modified-tick (buffer-modified-tick))) + (comint-replace-by-expanded-history-before-point silent start) + (/= previous-modified-tick (buffer-modified-tick))))) + + +(defun comint-replace-by-expanded-history-before-point (silent &optional start) + "Expand directory stack reference before point. +See `comint-replace-by-expanded-history'. Returns t if successful. + +If the optional argument START is non-nil, that specifies the +start of the text to scan for history references, rather +than the logical beginning of line." + (save-excursion + (let ((toend (- (line-end-position) (point))) + (start (comint-line-beginning-position))) + (goto-char start) + (while (progn + (skip-chars-forward "^!^" (- (line-end-position) toend)) + (< (point) (- (line-end-position) toend))) + ;; This seems a bit complex. We look for references such as !!, !-num, + ;; !foo, !?foo, !{bar}, !?{bar}, ^oh, ^my^, ^god^it, ^never^ends^. + ;; If that wasn't enough, the plings can be suffixed with argument + ;; range specifiers. + ;; Argument ranges are complex too, so we hive off the input line, + ;; referenced with plings, with the range string to `comint-args'. + (setq comint-input-ring-index nil) + (cond ((or (= (preceding-char) ?\\) + (comint-within-quotes start (point))) + ;; The history is quoted, or we're in quotes. + (goto-char (1+ (point)))) + ((looking-at "![0-9]+\\($\\|[^-]\\)") + ;; We cannot know the interpreter's idea of input line numbers. + (goto-char (match-end 0)) + (message "Absolute reference cannot be expanded")) + ((looking-at "!-\\([0-9]+\\)\\(:?[0-9^$*-]+\\)?") + ;; Just a number of args from `number' lines backward. + (let ((number (1- (string-to-number + (buffer-substring (match-beginning 1) + (match-end 1)))))) + (if (<= number (ring-length comint-input-ring)) + (progn + (replace-match + (comint-args (comint-previous-input-string number) + (match-beginning 2) (match-end 2)) + t t) + (setq comint-input-ring-index number) + (message "History item: %d" (1+ number))) + (goto-char (match-end 0)) + (message "Relative reference exceeds input history size")))) + ((or (looking-at "!!?:?\\([0-9^$*-]+\\)") (looking-at "!!")) + ;; Just a number of args from the previous input line. + (replace-match + (comint-args (comint-previous-input-string 0) + (match-beginning 1) (match-end 1)) + t t) + (message "History item: previous")) + ((looking-at + "!\\??\\({\\(.+\\)}\\|\\(\\sw+\\)\\)\\(:?[0-9^$*-]+\\)?") + ;; Most recent input starting with or containing (possibly + ;; protected) string, maybe just a number of args. Phew. + (let* ((mb1 (match-beginning 1)) (me1 (match-end 1)) + (mb2 (match-beginning 2)) (me2 (match-end 2)) + (exp (buffer-substring (or mb2 mb1) (or me2 me1))) + (pref (if (save-match-data (looking-at "!\\?")) "" "^")) + (pos (save-match-data + (comint-previous-matching-input-string-position + (concat pref (regexp-quote exp)) 1)))) + (if (null pos) + (progn + (goto-char (match-end 0)) + (or silent + (progn (message "Not found") + (ding)))) + (setq comint-input-ring-index pos) + (replace-match + (comint-args (ring-ref comint-input-ring pos) + (match-beginning 4) (match-end 4)) + t t) + (message "History item: %d" (1+ pos))))) + ((looking-at "\\^\\([^^]+\\)\\^?\\([^^]*\\)\\^?") + ;; Quick substitution on the previous input line. + (let ((old (buffer-substring (match-beginning 1) (match-end 1))) + (new (buffer-substring (match-beginning 2) (match-end 2))) + (pos nil)) + (replace-match (comint-previous-input-string 0) t t) + (setq pos (point)) + (goto-char (match-beginning 0)) + (if (not (search-forward old pos t)) + (or silent + (error "Not found")) + (replace-match new t t) + (message "History item: substituted")))) + (t + (forward-char 1))))))) + + +(defun comint-magic-space (arg) + "Expand input history references before point and insert ARG spaces. +A useful command to bind to SPC. See `comint-replace-by-expanded-history'." + (interactive "p") + (comint-replace-by-expanded-history) + (self-insert-command arg)) + +(defun comint-within-quotes (beg end) + "Return t if the number of quotes between BEG and END is odd. +Quotes are single and double." + (let ((countsq (comint-how-many-region "\\(^\\|[^\\\\]\\)\'" beg end)) + (countdq (comint-how-many-region "\\(^\\|[^\\\\]\\)\"" beg end))) + (or (= (mod countsq 2) 1) (= (mod countdq 2) 1)))) + +(defun comint-how-many-region (regexp beg end) + "Return number of matches for REGEXP from BEG to END." + (let ((count 0)) + (save-excursion + (save-match-data + (goto-char beg) + (while (re-search-forward regexp end t) + (setq count (1+ count))))) + count)) + +(defun comint-args (string begin end) + ;; From STRING, return the args depending on the range specified in the text + ;; from BEGIN to END. If BEGIN is nil, assume all args. Ignore leading `:'. + ;; Range can be x-y, x-, -y, where x/y can be [0-9], *, ^, $. + (save-match-data + (if (null begin) + (comint-arguments string 0 nil) + (let* ((range (buffer-substring + (if (eq (char-after begin) ?:) (1+ begin) begin) end)) + (nth (cond ((string-match "^[*^]" range) 1) + ((string-match "^-" range) 0) + ((string-equal range "$") nil) + (t (string-to-number range)))) + (mth (cond ((string-match "[-*$]$" range) nil) + ((string-match "-" range) + (string-to-number (substring range (match-end 0)))) + (t nth)))) + (comint-arguments string nth mth))))) + +;; Return a list of arguments from ARG. Break it up at the +;; delimiters in comint-delimiter-argument-list. Returned list is backwards. +(defun comint-delim-arg (arg) + (if (null comint-delimiter-argument-list) + (list arg) + (let ((args nil) + (pos 0) + (len (length arg))) + (while (< pos len) + (let ((char (aref arg pos)) + (start pos)) + (if (memq char comint-delimiter-argument-list) + (while (and (< pos len) (eq (aref arg pos) char)) + (setq pos (1+ pos))) + (while (and (< pos len) + (not (memq (aref arg pos) + comint-delimiter-argument-list))) + (setq pos (1+ pos)))) + (setq args (cons (substring arg start pos) args)))) + args))) + +(defun comint-arguments (string nth mth) + "Return from STRING the NTH to MTH arguments. +NTH and/or MTH can be nil, which means the last argument. +Returned arguments are separated by single spaces. +We assume whitespace separates arguments, except within quotes +and except for a space or tab that immediately follows a backslash. +Also, a run of one or more of a single character +in `comint-delimiter-argument-list' is a separate argument. +Argument 0 is the command name." + ;; The first line handles ordinary characters and backslash-sequences + ;; (except with w32 msdos-like shells, where backslashes are valid). + ;; The second matches "-quoted strings. + ;; The third matches '-quoted strings. + ;; The fourth matches `-quoted strings. + ;; This seems to fit the syntax of BASH 2.0. + (let* ((first (if (and (eq system-type 'windows-nt) + (w32-shell-dos-semantics)) + "[^ \n\t\"'`]+\\|" + "[^ \n\t\"'`\\]+\\|\\\\[\"'`\\ \t]+\\|")) + (argpart (concat first + "\\(\"\\([^\"\\]\\|\\\\.\\)*\"\\|\ +'[^']*'\\|\ +`[^`]*`\\)")) + (args ()) (pos 0) + (count 0) + beg str value quotes) + ;; Build a list of all the args until we have as many as we want. + (while (and (or (null mth) (<= count mth)) + (string-match argpart string pos)) + (if (and beg (= pos (match-beginning 0))) + ;; It's contiguous, part of the same arg. + (setq pos (match-end 0) + quotes (or quotes (match-beginning 1))) + ;; It's a new separate arg. + (if beg + ;; Put the previous arg, if there was one, onto ARGS. + (setq str (substring string beg pos) + args (if quotes (cons str args) + (nconc (comint-delim-arg str) args)) + count (1+ count))) + (setq quotes (match-beginning 1)) + (setq beg (match-beginning 0)) + (setq pos (match-end 0)))) + (if beg + (setq str (substring string beg pos) + args (if quotes (cons str args) + (nconc (comint-delim-arg str) args)) + count (1+ count))) + (let ((n (or nth (1- count))) + (m (if mth (1- (- count mth)) 0))) + (mapconcat + (function (lambda (a) a)) (nthcdr n (nreverse (nthcdr m args))) " ")))) + +;; +;; Input processing stuff +;; +(defun comint-add-to-input-history (cmd) + "Add CMD to the input history. +Ignore duplicates if `comint-input-ignoredups' is non-nil." + (if (and (funcall comint-input-filter cmd) + (or (null comint-input-ignoredups) + (not (ring-p comint-input-ring)) + (ring-empty-p comint-input-ring) + (not (string-equal (ring-ref comint-input-ring 0) + cmd)))) + (ring-insert comint-input-ring cmd))) + +(defun comint-send-input () + "Send input to process. +After the process output mark, sends all text from the process mark to +point as input to the process. Before the process output mark, calls value +of variable `comint-get-old-input' to retrieve old input, copies it to the +process mark, and sends it. If variable `comint-process-echoes' is nil, +a terminal newline is also inserted into the buffer and sent to the process +\(if it is non-nil, all text from the process mark to point is deleted, +since it is assumed the remote process will re-echo it). + +Any history reference may be expanded depending on the value of the variable +`comint-input-autoexpand'. The list of function names contained in the value +of `comint-input-filter-functions' is called on the input before sending it. +The input is entered into the input history ring, if the value of variable +`comint-input-filter' returns non-nil when called on the input. + +If variable `comint-eol-on-send' is non-nil, then point is moved to the +end of line before sending the input. + +The values of `comint-get-old-input', `comint-input-filter-functions', and +`comint-input-filter' are chosen according to the command interpreter running +in the buffer. E.g., + +If the interpreter is the csh, + comint-get-old-input is the default: + If `comint-use-prompt-regexp-instead-of-fields' is nil, then + either return the current input field, if point is on an input + field, or the current line, if point is on an output field. + If `comint-use-prompt-regexp-instead-of-fields' is non-nil, then + return the current line with any initial string matching the + regexp `comint-prompt-regexp' removed. + comint-input-filter-functions monitors input for \"cd\", \"pushd\", and + \"popd\" commands. When it sees one, it cd's the buffer. + comint-input-filter is the default: returns t if the input isn't all white + space. + +If the comint is Lucid Common Lisp, + comint-get-old-input snarfs the sexp ending at point. + comint-input-filter-functions does nothing. + comint-input-filter returns nil if the input matches input-filter-regexp, + which matches (1) all whitespace (2) :a, :c, etc. + +Similarly for Soar, Scheme, etc." + (interactive) + ;; Note that the input string does not include its terminal newline. + (let ((proc (get-buffer-process (current-buffer)))) + (if (not proc) (error "Current buffer has no process") + (let* ((pmark (process-mark proc)) + (intxt (if (>= (point) (marker-position pmark)) + (progn (if comint-eol-on-send (end-of-line)) + (buffer-substring pmark (point))) + (let ((copy (funcall comint-get-old-input))) + (goto-char pmark) + (insert copy) + copy))) + (input (if (not (eq comint-input-autoexpand 'input)) + ;; Just whatever's already there + intxt + ;; Expand and leave it visible in buffer + (comint-replace-by-expanded-history t pmark) + (buffer-substring pmark (point)))) + (history (if (not (eq comint-input-autoexpand 'history)) + input + ;; This is messy 'cos ultimately the original + ;; functions used do insertion, rather than return + ;; strings. We have to expand, then insert back. + (comint-replace-by-expanded-history t pmark) + (let ((copy (buffer-substring pmark (point))) + (start (point))) + (insert input) + (delete-region pmark start) + copy)))) + + (insert ?\n) + + (comint-add-to-input-history history) + + (run-hook-with-args 'comint-input-filter-functions + (concat input "\n")) + + (let ((beg (marker-position pmark)) + (end (1- (point)))) + (when (not (> beg end)) ; handle a special case + ;; Make an overlay for the input field + (let ((over (make-overlay beg end nil nil t))) + (unless comint-use-prompt-regexp-instead-of-fields + ;; Give old user input a field property of `input', to + ;; distinguish it from both process output and unsent + ;; input. The terminating newline is put into a special + ;; `boundary' field to make cursor movement between input + ;; and output fields smoother. + (overlay-put over 'field 'input)) + (when comint-highlight-input + (overlay-put over 'face 'comint-highlight-input) + (overlay-put over 'mouse-face 'highlight) + (overlay-put over + 'help-echo + "mouse-2: insert after prompt as new input") + (overlay-put over 'evaporate t)))) + (unless comint-use-prompt-regexp-instead-of-fields + ;; Make an overlay for the terminating newline + (let ((over (make-overlay end (1+ end) nil t nil))) + (overlay-put over 'field 'boundary) + (overlay-put over 'inhibit-line-move-field-capture t) + (overlay-put over 'evaporate t)))) + + (comint-snapshot-last-prompt) + + (setq comint-save-input-ring-index comint-input-ring-index) + (setq comint-input-ring-index nil) + ;; Update the markers before we send the input + ;; in case we get output amidst sending the input. + (set-marker comint-last-input-start pmark) + (set-marker comint-last-input-end (point)) + (set-marker (process-mark proc) (point)) + ;; clear the "accumulation" marker + (set-marker comint-accum-marker nil) + (funcall comint-input-sender proc input) + + ;; Optionally delete echoed input (after checking it). + (when comint-process-echoes + (let ((echo-len (- comint-last-input-end + comint-last-input-start))) + ;; Wait for all input to be echoed: + (while (and (accept-process-output proc) + (> (+ comint-last-input-end echo-len) + (point-max)) + (zerop + (compare-buffer-substrings + nil comint-last-input-start + (- (point-max) echo-len) + ;; Above difference is equivalent to + ;; (+ comint-last-input-start + ;; (- (point-max) comint-last-input-end)) + nil comint-last-input-end (point-max))))) + (if (and + (<= (+ comint-last-input-end echo-len) + (point-max)) + (zerop + (compare-buffer-substrings + nil comint-last-input-start comint-last-input-end + nil comint-last-input-end + (+ comint-last-input-end echo-len)))) + (delete-region comint-last-input-end + (+ comint-last-input-end echo-len))))) + + ;; This used to call comint-output-filter-functions, + ;; but that scrolled the buffer in undesirable ways. + (run-hook-with-args 'comint-output-filter-functions ""))))) + +(defvar comint-preoutput-filter-functions nil + "List of functions to call before inserting Comint output into the buffer. +Each function gets one argument, a string containing the text received +from the subprocess. It should return the string to insert, perhaps +the same string that was received, or perhaps a modified or transformed +string. + +The functions on the list are called sequentially, and each one is +given the string returned by the previous one. The string returned by +the last function is the text that is actually inserted in the +redirection buffer. + +This variable is permanent-local.") + +;; When non-nil, this is the last overlay used for output. +;; It is kept around so that we can extend it instead of creating +;; multiple contiguous overlays for multiple contiguous output chunks. +(defvar comint-last-output-overlay nil) + +;; When non-nil, this is an overlay over the last recognized prompt in +;; the buffer; it is used when highlighting the prompt. +(defvar comint-last-prompt-overlay nil) + +;; `snapshot' any current comint-last-prompt-overlay, freezing it in place. +;; Any further output will then create a new comint-last-prompt-overlay. +(defun comint-snapshot-last-prompt () + (when comint-last-prompt-overlay + (overlay-put comint-last-prompt-overlay 'evaporate t) + (setq comint-last-prompt-overlay nil))) + +(defun comint-carriage-motion (string) + "Handle carriage control characters in comint output. +Translate carriage return/linefeed sequences to linefeeds. +Make single carriage returns delete to the beginning of the line. +Make backspaces delete the previous character. + +This function should be in the list `comint-output-filter-functions'." + (save-match-data + ;; We first check to see if STRING contains any magic characters, to + ;; avoid overhead in the common case where it does not + (when (string-match "[\r\b]" string) + (let ((pmark (process-mark (get-buffer-process (current-buffer))))) + (save-excursion + (save-restriction + (widen) + (let ((inhibit-field-text-motion t) + (buffer-read-only nil)) + ;; CR LF -> LF + ;; Note that this won't work properly when the CR and LF + ;; are in different output chunks, but this is probably an + ;; exceedingly rare case (because they are generally + ;; written as a unit), and to delay interpretation of a + ;; trailing CR in a chunk would result in odd interactive + ;; behavior (and this case is probably far more common). + (goto-char comint-last-output-start) + (while (re-search-forward "\r$" pmark t) + (delete-char -1)) + ;; bare CR -> delete preceding line + (goto-char comint-last-output-start) + (while (search-forward "\r" pmark t) + (delete-region (point) (line-beginning-position))) + ;; BS -> delete preceding character + (goto-char comint-last-output-start) + (while (search-forward "\b" pmark t) + (delete-char -2))))))))) + +(add-hook 'comint-output-filter-functions 'comint-carriage-motion) + +;; The purpose of using this filter for comint processes +;; is to keep comint-last-input-end from moving forward +;; when output is inserted. +(defun comint-output-filter (process string) + (let ((oprocbuf (process-buffer process))) + ;; First check for killed buffer or no input. + (when (and string oprocbuf (buffer-name oprocbuf)) + (with-current-buffer oprocbuf + (comint-insert-output process string))))) + +(defun comint-insert-output (process string) + (if comint-allow-output-p + (progn + ;; Run preoutput filters + (let ((functions comint-preoutput-filter-functions)) + (while (and functions string) + (setq string (funcall (car functions) string)) + (setq functions (cdr functions)))) + + ;; Insert STRING + (let ((buffer-read-only nil) + ;; Avoid the overhead of save-excursion, since we just + ;; fiddle with the point + (saved-point (point-marker))) + + ;; The point should float after any insertion we do + (set-marker-insertion-type saved-point t) + + ;; We temporarly remove any buffer narrowing, in case the + ;; process mark is outside of the restriction + (save-restriction + (widen) + + (goto-char (process-mark process)) + (set-marker comint-last-output-start (point)) + + ;; insert-before-markers is a bad thing. XXX + ;; + ;; It is used here to force window-point markers (used to + ;; store the value of point in non-selected windows) to + ;; advance, but it also screws up any other markers that we + ;; don't _want_ to advance, such as the start-marker of some + ;; of the overlays we create. + ;; + ;; We work around the problem with the overlays by + ;; explicitly adjusting them after we do the insertion, but + ;; in the future this problem should be solved correctly, by + ;; using `insert', and making the insertion-type of + ;; window-point markers settable (via a buffer-local + ;; variable). In comint buffers, this variable would be set + ;; to `t', to cause point in non-select windows to advance. + (insert-before-markers string) + ;; Fixup markers and overlays that got screwed up because we + ;; used `insert-before-markers'. + (let ((old-point (- (point) (length string)))) + ;; comint-last-output-start + (set-marker comint-last-output-start old-point) + ;; comint-last-input-end + (when (and comint-last-input-end + (equal (marker-position comint-last-input-end) + (point))) + (set-marker comint-last-input-end old-point)) + ;; No overlays we create are set to advance upon insertion + ;; (at the start/end), so we assume that any overlay which + ;; is at the current point was incorrectly advanced by + ;; insert-before-markers. First fixup overlays that might + ;; start at point: + (dolist (over (overlays-at (point))) + (when (= (overlay-start over) (point)) + (let ((end (overlay-end over))) + (move-overlay over + old-point + (if (= end (point)) old-point end))))) + ;; Then do overlays that might end at point: + (dolist (over (overlays-at (1- (point)))) + (when (= (overlay-end over) (point)) + (move-overlay over + (min (overlay-start over) old-point) + old-point)))) + + ;; Advance process-mark + (set-marker (process-mark process) (point)) + + (unless comint-use-prompt-regexp-instead-of-fields + ;; We check to see if the last overlay used for output is + ;; adjacent to the new input, and if so, just extend it. + (if (and comint-last-output-overlay + (equal (overlay-end comint-last-output-overlay) + (marker-position comint-last-output-start))) + ;; Extend comint-last-output-overlay to include the + ;; most recent output + (move-overlay comint-last-output-overlay + (overlay-start comint-last-output-overlay) + (point)) + ;; Create a new overlay + (let ((over (make-overlay comint-last-output-start (point)))) + (overlay-put over 'field 'output) + (overlay-put over 'inhibit-line-move-field-capture t) + (overlay-put over 'evaporate t) + (setq comint-last-output-overlay over)))) + + (when comint-highlight-prompt + ;; Highlight the prompt, where we define `prompt' to mean + ;; the most recent output that doesn't end with a newline. + (unless (and (bolp) (null comint-last-prompt-overlay)) + ;; Need to create or move the prompt overlay (in the case + ;; where there is no prompt ((bolp) == t), we still do + ;; this if there's already an existing overlay). + (let ((prompt-start (save-excursion (forward-line 0) (point)))) + (if comint-last-prompt-overlay + ;; Just move an existing overlay + (move-overlay comint-last-prompt-overlay + prompt-start (point)) + ;; Need to create the overlay + (setq comint-last-prompt-overlay + (make-overlay prompt-start (point))) + (overlay-put comint-last-prompt-overlay + 'face 'comint-highlight-prompt))))) + + (goto-char saved-point) + + (run-hook-with-args 'comint-output-filter-functions string)))) + (run-hook-with-args 'comint-unallowed-output-filter-functions string))) + +(defun comint-dispatch-filter-initialize () + (setq comint-dispatch-state 'idle)) + +(defun comint-dispatch-output-filter (process input) + (let ((buffer (process-buffer process)) + (inhibit-quit nil)) ;MDJ + (if (and buffer (buffer-name buffer)) + (let ((old-buffer (current-buffer))) + (unwind-protect + (progn + (set-buffer buffer) + (while input + (cond ((eq comint-dispatch-state 'idle) + (let ((start (string-match + comint-dispatch-escape-character + input))) + (if start + (progn + (comint-insert-output + process + (substring input 0 start)) + (setq input + (substring input (1+ start))) + (setq comint-dispatch-state 'reading-type)) + (comint-insert-output process input) + (setq input nil)))) + ((eq comint-dispatch-state 'reading-type) + (if (zerop (length input)) + (setq input nil) + (let ((char (aref input 0))) + (setq input (substring input 1)) + (let ((entry (assq char comint-dispatch-alist))) + (if entry + (funcall (nth 2 entry) (nth 1 entry)) + (progn + (comint-insert-output + process + (concat comint-dispatch-escape-character + (char-to-string char))) + (setq comint-dispatch-state 'idle))))))) + ((eq comint-dispatch-state 'reading-string) + (let ((end (string-match + comint-dispatch-string-end-regexp + input))) + (if end + (let ((string + (concat comint-string-accumulator + (substring input 0 end)))) + (setq input + (substring input (match-end 0))) + (setq comint-dispatch-state 'idle) + (funcall comint-string-receiver string)) + (setq comint-string-accumulator + (concat comint-string-accumulator input)) + (setq input nil)))) + ((eq comint-dispatch-state 'reading-to-buffer) + (let ((end (string-match + comint-dispatch-buffer-end-regexp + input))) + (if end + (progn + (save-excursion + (set-buffer comint-receiving-buffer) + (insert (substring input 0 end))) + (setq input + (substring input (match-end 0))) + (setq comint-dispatch-state 'idle) + (funcall comint-buffer-receiver + comint-receiving-buffer)) + (save-excursion + (set-buffer comint-receiving-buffer) + (insert input)) + (setq input nil)))) + (t + (error "Scheme process filter -- bad state"))))) + (set-buffer old-buffer)))))) + +(put 'comint-dispatch-output-filter 'initialize + 'comint-dispatch-filter-initialize) + +(defvar comint-dispatch-escape-character "\032" + "The escape character which introduces commands from the process. +See `comint-dispatch-output-filter'.") + +(defvar comint-dispatch-string-end-regexp "\032\\.") + +(defvar comint-dispatch-buffer-end-regexp "\032\\.") + +(defvar comint-dispatch-alist '() + "Table used to decide how to handle process filter commands. +Value is a list of entries, each entry is a list of three items. + +The first item is the character that the process filter dispatches on. +The second item is the action to be taken, a function. +The third item is the handler for the entry, a function. + +When the process filter sees a command whose character matches a +particular entry, it calls the handler with two arguments: the action +and the string containing the rest of the process filter's input +stream. It is the responsibility of the handler to invoke the action +with the appropriate arguments, and to reenter the process filter with +the remaining input.") + +(defun comint-preinput-scroll-to-bottom () + "Go to the end of buffer in all windows showing it. +Movement occurs if point in the selected window is not after the process mark, +and `this-command' is an insertion command. Insertion commands recognised +are `self-insert-command', `comint-magic-space', `yank', and `hilit-yank'. +Depends on the value of `comint-scroll-to-bottom-on-input'. + +This function should be a pre-command hook." + (if (and comint-scroll-to-bottom-on-input + (memq this-command '(self-insert-command comint-magic-space yank + hilit-yank))) + (let* ((selected (selected-window)) + (current (current-buffer)) + (process (get-buffer-process current)) + (scroll comint-scroll-to-bottom-on-input)) + (if (and process (< (point) (process-mark process))) + (if (eq scroll 'this) + (goto-char (point-max)) + (walk-windows + (function (lambda (window) + (if (and (eq (window-buffer window) current) + (or (eq scroll t) (eq scroll 'all))) + (progn + (select-window window) + (goto-char (point-max)) + (select-window selected))))) + nil t)))))) + +(defun comint-postoutput-scroll-to-bottom (string) + "Go to the end of buffer in all windows showing it. +Does not scroll if the current line is the last line in the buffer. +Depends on the value of `comint-scroll-to-bottom-on-output' and +`comint-scroll-show-maximum-output'. + +This function should be in the list `comint-output-filter-functions'." + (let* ((selected (selected-window)) + (current (current-buffer)) + (process (get-buffer-process current)) + (scroll comint-scroll-to-bottom-on-output)) + (unwind-protect + (if process + (walk-windows + (function (lambda (window) + (if (eq (window-buffer window) current) + (progn + (select-window window) + (if (and (< (point) (process-mark process)) + (or (eq scroll t) (eq scroll 'all) + ;; Maybe user wants point to jump to end. + (and (eq scroll 'this) (eq selected window)) + (and (eq scroll 'others) (not (eq selected window))) + ;; If point was at the end, keep it at end. + (and (marker-position comint-last-output-start) + (>= (point) comint-last-output-start)))) + (goto-char (process-mark process))) + ;; Optionally scroll so that the text + ;; ends at the bottom of the window. + (if (and comint-scroll-show-maximum-output + (>= (point) (process-mark process))) + (save-excursion + (goto-char (point-max)) + (recenter -1))) + (select-window selected))))) + nil t)) + (set-buffer current)))) + +(defun comint-truncate-buffer (&optional string) + "Truncate the buffer to `comint-buffer-maximum-size'. +This function could be on `comint-output-filter-functions' or bound to a key." + (interactive) + (save-excursion + (goto-char (process-mark (get-buffer-process (current-buffer)))) + (forward-line (- comint-buffer-maximum-size)) + (beginning-of-line) + (delete-region (point-min) (point)))) + +(defun comint-strip-ctrl-m (&optional string) + "Strip trailing `^M' characters from the current output group. +This function could be on `comint-output-filter-functions' or bound to a key." + (interactive) + (let ((pmark (process-mark (get-buffer-process (current-buffer))))) + (save-excursion + (condition-case nil + (goto-char + (if (interactive-p) comint-last-input-end comint-last-output-start)) + (error nil)) + (while (re-search-forward "\r+$" pmark t) + (replace-match "" t t))))) +(defalias 'shell-strip-ctrl-m 'comint-strip-ctrl-m) + +(defun comint-show-maximum-output () + "Put the end of the buffer at the bottom of the window." + (interactive) + (goto-char (point-max)) + (recenter -1)) + +(defun comint-get-old-input-default () + "Default for `comint-get-old-input'. +If `comint-use-prompt-regexp-instead-of-fields' is nil, then either +return the current input field, if point is on an input field, or the +current line, if point is on an output field. +If `comint-use-prompt-regexp-instead-of-fields' is non-nil, then return +the current line with any initial string matching the regexp +`comint-prompt-regexp' removed." + (let ((bof (field-beginning))) + (if (eq (get-char-property bof 'field) 'input) + (field-string bof) + (comint-bol) + (buffer-substring (point) (line-end-position))))) + +(defun comint-copy-old-input () + "Insert after prompt old input at point as new input to be edited. +Calls `comint-get-old-input' to get old input." + (interactive) + (let ((input (funcall comint-get-old-input)) + (process (get-buffer-process (current-buffer)))) + (if (not process) + (error "Current buffer has no process") + (goto-char (process-mark process)) + (insert input)))) + +(defun comint-skip-prompt () + "Skip past the text matching regexp `comint-prompt-regexp'. +If this takes us past the end of the current line, don't skip at all." + (let ((eol (save-excursion (end-of-line) (point)))) + (if (and (looking-at comint-prompt-regexp) + (<= (match-end 0) eol)) + (goto-char (match-end 0))))) + +(defun comint-after-pmark-p () + "Return t if point is after the process output marker." + (let ((pmark (process-mark (get-buffer-process (current-buffer))))) + (<= (marker-position pmark) (point)))) + +(defun comint-simple-send (proc string) + "Default function for sending to PROC input STRING. +This just sends STRING plus a newline. To override this, +set the hook `comint-input-sender'." + (comint-send-string proc string) + (comint-send-string proc "\n")) + +(defun comint-line-beginning-position () + "Returns the buffer position of the beginning of the line, after any prompt. +If `comint-use-prompt-regexp-instead-of-fields' is non-nil, then the +prompt skip is done by skipping text matching the regular expression +`comint-prompt-regexp', a buffer local variable." + (if comint-use-prompt-regexp-instead-of-fields + ;; Use comint-prompt-regexp + (save-excursion + (beginning-of-line) + (comint-skip-prompt) + (point)) + ;; Use input fields. Note that, unlike the behavior of + ;; `line-beginning-position' inside a field, this function will + ;; return the position of the end of a prompt, even if the point is + ;; already inside the prompt. In order to do this, it assumes that + ;; if there are two fields on a line, then the first one is the + ;; prompt, and the second one is an input field, and is front-sticky + ;; (as input fields should be). + (constrain-to-field (line-beginning-position) (line-end-position)))) + +(defun comint-bol (&optional arg) + "Goes to the beginning of line, then skips past the prompt, if any. +If prefix argument is given (\\[universal-argument]) the prompt is not skipped. +If `comint-use-prompt-regexp-instead-of-fields' is non-nil, then the +prompt skip is done by skipping text matching the regular expression +`comint-prompt-regexp', a buffer local variable." + (interactive "P") + (if arg + ;; Unlike `beginning-of-line', forward-line ignores field boundaries + (forward-line 0) + (goto-char (comint-line-beginning-position)))) + +;; These three functions are for entering text you don't want echoed or +;; saved -- typically passwords to ftp, telnet, or somesuch. +;; Just enter m-x send-invisible and type in your line, or add +;; `comint-watch-for-password-prompt' to `comint-output-filter-functions'. + +(defun comint-read-noecho (prompt &optional stars) + "Read a single line of text from user without echoing, and return it. +Prompt with argument PROMPT, a string. Optional argument STARS causes +input to be echoed with '*' characters on the prompt line. Input ends with +RET, LFD, or ESC. DEL or C-h rubs out. C-u kills line. C-g aborts (if +`inhibit-quit' is set because e.g. this function was called from a process +filter and C-g is pressed, this function returns nil rather than a string). + +Note that the keystrokes comprising the text can still be recovered +\(temporarily) with \\[view-lossage]. Some people find this worrysome. +Once the caller uses the password, it can erase the password +by doing (fillarray STRING 0)." + (let ((ans "") + (newans nil) + (c 0) + (echo-keystrokes 0) + (cursor-in-echo-area t) + (message-log-max nil) + (done nil)) + (while (not done) + (if stars + (message "%s%s" prompt (make-string (length ans) ?*)) + (message "%s" prompt)) + ;; Use this instead of `read-char' to avoid "Non-character input-event". + (setq c (read-char-exclusive)) + (cond ((= c ?\C-g) + ;; This function may get called from a process filter, where + ;; inhibit-quit is set. In later versions of emacs read-char + ;; may clear quit-flag itself and return C-g. That would make + ;; it impossible to quit this loop in a simple way, so + ;; re-enable it here (for backward-compatibility the check for + ;; quit-flag below would still be necessary, so this seems + ;; like the simplest way to do things). + (setq quit-flag t + done t)) + ((or (= c ?\r) (= c ?\n) (= c ?\e)) + (setq done t)) + ((= c ?\C-u) + (fillarray ans 0) + (setq ans "")) + ((and (/= c ?\b) (/= c ?\177)) + (setq newans (concat ans (char-to-string c))) + (fillarray ans 0) + (setq ans newans)) + ((> (length ans) 0) + (aset ans (1- (length ans)) 0) + (setq ans (substring ans 0 -1))))) + (if quit-flag + ;; Emulate a true quit, except that we have to return a value. + (prog1 + (setq quit-flag nil) + (message "Quit") + (beep t)) + (message "") + ans))) + +(defun send-invisible (str) + "Read a string without echoing. +Then send it to the process running in the current buffer. +The string is sent using `comint-input-sender'. +Security bug: your string can still be temporarily recovered with +\\[view-lossage]." + (interactive "P") ; Defeat snooping via C-x ESC ESC + (let ((proc (get-buffer-process (current-buffer)))) + (cond ((not proc) + (error "Current buffer has no process")) + ((stringp str) + (comint-snapshot-last-prompt) + (funcall comint-input-sender proc str)) + (t + (let ((str (comint-read-noecho "Non-echoed text: " t))) + (if (stringp str) + (send-invisible str) + (message "Warning: text will be echoed"))))))) + +(defun comint-watch-for-password-prompt (string) + "Prompt in the minibuffer for password and send without echoing. +This function uses `send-invisible' to read and send a password to the buffer's +process if STRING contains a password prompt defined by +`comint-password-prompt-regexp'. + +This function could be in the list `comint-output-filter-functions'." + (when (string-match comint-password-prompt-regexp string) + (let ((pw (comint-read-noecho string t))) + (send-invisible pw)))) + +;; Low-level process communication + +(defun comint-send-string (process string) + "Like `process-send-string', but also does extra bookkeeping for comint mode." + (if process + (with-current-buffer (if (processp process) + (process-buffer process) + (get-buffer process)) + (comint-snapshot-last-prompt)) + (comint-snapshot-last-prompt)) + (process-send-string process string)) + +(defun comint-send-region (process start end) + "Like `process-send-region', but also does extra bookkeeping for comint mode." + (if process + (with-current-buffer (if (processp process) + (process-buffer process) + (get-buffer process)) + (comint-snapshot-last-prompt)) + (comint-snapshot-last-prompt)) + (process-send-region process start end)) + +;; Random input hackage + +(defun comint-delete-output () + "Delete all output from interpreter since last input. +Does not delete the prompt." + (interactive) + (let ((proc (get-buffer-process (current-buffer))) + (replacement nil)) + (save-excursion + (let ((pmark (progn (goto-char (process-mark proc)) + (forward-line 0) + (point-marker)))) + (delete-region comint-last-input-end pmark) + (goto-char (process-mark proc)) + (setq replacement (concat "*** output flushed ***\n" + (buffer-substring pmark (point)))) + (delete-region pmark (point)))) + ;; Output message and put back prompt + (comint-output-filter proc replacement))) +(defalias 'comint-kill-output 'comint-delete-output) +(make-obsolete 'comint-kill-output 'comint-delete-output "21.1") + +(defun comint-write-output (filename &optional append mustbenew) + "Write output from interpreter since last input to FILENAME. +Any prompt at the end of the output is not written. + +If the optional argument APPEND (the prefix argument when interactive) +is non-nil, the output is appended to the file instead. + +If the optional argument MUSTBENEW is non-nil, check for an existing +file with the same name. If MUSTBENEW is `excl', that means to get an +error if the file already exists; never overwrite. If MUSTBENEW is +neither nil nor `excl', that means ask for confirmation before +overwriting, but do go ahead and overwrite the file if the user +confirms. When interactive, MUSTBENEW is nil when appending, and t +otherwise." + (interactive + (list (read-file-name + (if current-prefix-arg + "Append output to file: " + "Write output to file: ")) + current-prefix-arg + (not current-prefix-arg))) + (save-excursion + (goto-char (process-mark (get-buffer-process (current-buffer)))) + (forward-line 0) + (write-region comint-last-input-end (point) filename + append nil nil mustbenew))) + +;; This function exists for the benefit of the menu; from the keyboard, +;; users can just use `comint-write-output' with a prefix arg. +(defun comint-append-output-to-file (filename) + "Append output from interpreter since last input to FILENAME. +Any prompt at the end of the output is not written." + (interactive "fAppend output to file: ") + (comint-write-output filename t)) + +(defun comint-show-output () + "Display start of this batch of interpreter output at top of window. +Sets mark to the value of point when this command is run." + (interactive) + (push-mark) + (let ((pos (or (marker-position comint-last-input-end) (point-max)))) + (cond (comint-use-prompt-regexp-instead-of-fields + (goto-char pos) + (beginning-of-line 0) + (set-window-start (selected-window) (point)) + (comint-skip-prompt)) + (t + (goto-char (field-beginning pos)) + (set-window-start (selected-window) (point)))))) + + +(defun comint-interrupt-subjob () + "Interrupt the current subjob. +This command also kills the pending input +between the process-mark and point." + (interactive) + (comint-kill-input) + (interrupt-process nil comint-ptyp)) + +(defun comint-kill-subjob () + "Send kill signal to the current subjob. +This command also kills the pending input +between the process-mark and point." + (interactive) + (comint-kill-input) + (kill-process nil comint-ptyp)) + +(defun comint-quit-subjob () + "Send quit signal to the current subjob. +This command also kills the pending input +between the process-mark and point." + (interactive) + (comint-kill-input) + (quit-process nil comint-ptyp)) + +(defun comint-stop-subjob () + "Stop the current subjob. +This command also kills the pending input +between the process-mark and point. + +WARNING: if there is no current subjob, you can end up suspending +the top-level process running in the buffer. If you accidentally do +this, use \\[comint-continue-subjob] to resume the process. (This +is not a problem with most shells, since they ignore this signal.)" + (interactive) + (comint-kill-input) + (stop-process nil comint-ptyp)) + +(defun comint-continue-subjob () + "Send CONT signal to process buffer's process group. +Useful if you accidentally suspend the top-level process." + (interactive) + (continue-process nil comint-ptyp)) + +(defun comint-kill-input () + "Kill all text from last stuff output by interpreter to point." + (interactive) + (let ((pmark (process-mark (get-buffer-process (current-buffer))))) + (if (> (point) (marker-position pmark)) + (kill-region pmark (point))))) + +(defun comint-delchar-or-maybe-eof (arg) + "Delete ARG characters forward or send an EOF to subprocess. +Sends an EOF only if point is at the end of the buffer and there is no input." + (interactive "p") + (let ((proc (get-buffer-process (current-buffer)))) + (if (and (eobp) proc (= (point) (marker-position (process-mark proc)))) + (comint-send-eof) + (delete-char arg)))) + +(defun comint-send-eof () + "Send an EOF to the current buffer's process." + (interactive) + (comint-snapshot-last-prompt) + (process-send-eof)) + + +(defun comint-backward-matching-input (regexp arg) + "Search backward through buffer for input fields that match REGEXP. +If `comint-use-prompt-regexp-instead-of-fields' is non-nil, then input +fields are identified by lines that match `comint-prompt-regexp'. + +With prefix argument N, search for Nth previous match. +If N is negative, find the next or Nth next match." + (interactive (comint-regexp-arg "Backward input matching (regexp): ")) + (if comint-use-prompt-regexp-instead-of-fields + ;; Use comint-prompt-regexp + (let* ((re (concat comint-prompt-regexp ".*" regexp)) + (pos (save-excursion (end-of-line (if (> arg 0) 0 1)) + (if (re-search-backward re nil t arg) + (point))))) + (if (null pos) + (progn (message "Not found") + (ding)) + (goto-char pos) + (comint-bol nil))) + ;; Use input fields + (let* ((dir (if (< arg 0) -1 1)) + (pos + (save-excursion + (while (/= arg 0) + (unless (re-search-backward regexp nil t dir) + (error "Not found")) + (when (eq (get-char-property (point) 'field) 'input) + (setq arg (- arg dir)))) + (field-beginning)))) + (goto-char pos)))) + + +(defun comint-forward-matching-input (regexp arg) + "Search forward through buffer for input fields that match REGEXP. +If `comint-use-prompt-regexp-instead-of-fields' is non-nil, then input +fields are identified by lines that match `comint-prompt-regexp'. + +With prefix argument N, search for Nth following match. +If N is negative, find the previous or Nth previous match." + (interactive (comint-regexp-arg "Forward input matching (regexp): ")) + (comint-backward-matching-input regexp (- arg))) + + +(defun comint-next-prompt (n) + "Move to end of Nth next prompt in the buffer. +If `comint-use-prompt-regexp-instead-of-fields' is nil, then this means +the beginning of the Nth next `input' field, otherwise, it means the Nth +occurance of text matching `comint-prompt-regexp'." + (interactive "p") + (if comint-use-prompt-regexp-instead-of-fields + ;; Use comint-prompt-regexp + (let ((paragraph-start comint-prompt-regexp)) + (end-of-line (if (> n 0) 1 0)) + (forward-paragraph n) + (comint-skip-prompt)) + ;; Use input fields + (let ((pos (point)) + (input-pos nil) + prev-pos) + (while (/= n 0) + (setq prev-pos pos) + (setq pos + (if (> n 0) + (next-single-char-property-change pos 'field) + (previous-single-char-property-change pos 'field))) + (cond ((or (null pos) (= pos prev-pos)) + ;; Ran off the end of the buffer. + (when (> n 0) + ;; There's always an input field at the end of the + ;; buffer, but it has a `field' property of nil. + (setq input-pos (point-max))) + ;; stop iterating + (setq n 0)) + ((eq (get-char-property pos 'field) 'input) + (setq n (if (< n 0) (1+ n) (1- n))) + (setq input-pos pos)))) + (when input-pos + (goto-char input-pos))))) + + +(defun comint-previous-prompt (n) + "Move to end of Nth previous prompt in the buffer. +If `comint-use-prompt-regexp-instead-of-fields' is nil, then this means +the beginning of the Nth previous `input' field, otherwise, it means the Nth +occurance of text matching `comint-prompt-regexp'." + (interactive "p") + (comint-next-prompt (- n))) + +;; Support for source-file processing commands. +;;============================================================================ +;; Many command-interpreters (e.g., Lisp, Scheme, Soar) have +;; commands that process files of source text (e.g. loading or compiling +;; files). So the corresponding process-in-a-buffer modes have commands +;; for doing this (e.g., lisp-load-file). The functions below are useful +;; for defining these commands. +;; +;; Alas, these guys don't do exactly the right thing for Lisp, Scheme +;; and Soar, in that they don't know anything about file extensions. +;; So the compile/load interface gets the wrong default occasionally. +;; The load-file/compile-file default mechanism could be smarter -- it +;; doesn't know about the relationship between filename extensions and +;; whether the file is source or executable. If you compile foo.lisp +;; with compile-file, then the next load-file should use foo.bin for +;; the default, not foo.lisp. This is tricky to do right, particularly +;; because the extension for executable files varies so much (.o, .bin, +;; .lbin, .mo, .vo, .ao, ...). + + +;; COMINT-SOURCE-DEFAULT -- determines defaults for source-file processing +;; commands. +;; +;; COMINT-CHECK-SOURCE -- if FNAME is in a modified buffer, asks you if you +;; want to save the buffer before issuing any process requests to the command +;; interpreter. +;; +;; COMINT-GET-SOURCE -- used by the source-file processing commands to prompt +;; for the file to process. + +;; (COMINT-SOURCE-DEFAULT previous-dir/file source-modes) +;;============================================================================ +;; This function computes the defaults for the load-file and compile-file +;; commands for tea, soar, cmulisp, and cmuscheme modes. +;; +;; - PREVIOUS-DIR/FILE is a pair (directory . filename) from the last +;; source-file processing command. NIL if there hasn't been one yet. +;; - SOURCE-MODES is a list used to determine what buffers contain source +;; files: if the major mode of the buffer is in SOURCE-MODES, it's source. +;; Typically, (lisp-mode) or (scheme-mode). +;; +;; If the command is given while the cursor is inside a string, *and* +;; the string is an existing filename, *and* the filename is not a directory, +;; then the string is taken as default. This allows you to just position +;; your cursor over a string that's a filename and have it taken as default. +;; +;; If the command is given in a file buffer whose major mode is in +;; SOURCE-MODES, then the the filename is the default file, and the +;; file's directory is the default directory. +;; +;; If the buffer isn't a source file buffer (e.g., it's the process buffer), +;; then the default directory & file are what was used in the last source-file +;; processing command (i.e., PREVIOUS-DIR/FILE). If this is the first time +;; the command has been run (PREVIOUS-DIR/FILE is nil), the default directory +;; is the cwd, with no default file. (\"no default file\" = nil) +;; +;; SOURCE-REGEXP is typically going to be something like (tea-mode) +;; for T programs, (lisp-mode) for Lisp programs, (soar-mode lisp-mode) +;; for Soar programs, etc. +;; +;; The function returns a pair: (default-directory . default-file). + +(defun comint-source-default (previous-dir/file source-modes) + (cond ((and buffer-file-name (memq major-mode source-modes)) + (cons (file-name-directory buffer-file-name) + (file-name-nondirectory buffer-file-name))) + (previous-dir/file) + (t + (cons default-directory nil)))) + + +;; (COMINT-CHECK-SOURCE fname) +;;============================================================================ +;; Prior to loading or compiling (or otherwise processing) a file (in the CMU +;; process-in-a-buffer modes), this function can be called on the filename. +;; If the file is loaded into a buffer, and the buffer is modified, the user +;; is queried to see if he wants to save the buffer before proceeding with +;; the load or compile. + +(defun comint-check-source (fname) + (let ((buff (get-file-buffer fname))) + (if (and buff + (buffer-modified-p buff) + (y-or-n-p (format "Save buffer %s first? " (buffer-name buff)))) + ;; save BUFF. + (let ((old-buffer (current-buffer))) + (set-buffer buff) + (save-buffer) + (set-buffer old-buffer))))) + + +;; (COMINT-GET-SOURCE prompt prev-dir/file source-modes mustmatch-p) +;;============================================================================ +;; COMINT-GET-SOURCE is used to prompt for filenames in command-interpreter +;; commands that process source files (like loading or compiling a file). +;; It prompts for the filename, provides a default, if there is one, +;; and returns the result filename. +;; +;; See COMINT-SOURCE-DEFAULT for more on determining defaults. +;; +;; PROMPT is the prompt string. PREV-DIR/FILE is the (directory . file) pair +;; from the last source processing command. SOURCE-MODES is a list of major +;; modes used to determine what file buffers contain source files. (These +;; two arguments are used for determining defaults). If MUSTMATCH-P is true, +;; then the filename reader will only accept a file that exists. +;; +;; A typical use: +;; (interactive (comint-get-source "Compile file: " prev-lisp-dir/file +;; '(lisp-mode) t)) + +;; This is pretty stupid about strings. It decides we're in a string +;; if there's a quote on both sides of point on the current line. +(defun comint-extract-string () + "Return string around POINT that starts the current line, or nil." + (save-excursion + (let* ((point (point)) + (bol (progn (beginning-of-line) (point))) + (eol (progn (end-of-line) (point))) + (start (progn (goto-char point) + (and (search-backward "\"" bol t) + (1+ (point))))) + (end (progn (goto-char point) + (and (search-forward "\"" eol t) + (1- (point)))))) + (and start end + (buffer-substring start end))))) + +(defun comint-get-source (prompt prev-dir/file source-modes mustmatch-p) + (let* ((def (comint-source-default prev-dir/file source-modes)) + (stringfile (comint-extract-string)) + (sfile-p (and stringfile + (condition-case () + (file-exists-p stringfile) + (error nil)) + (not (file-directory-p stringfile)))) + (defdir (if sfile-p (file-name-directory stringfile) + (car def))) + (deffile (if sfile-p (file-name-nondirectory stringfile) + (cdr def))) + (ans (read-file-name (if deffile (format "%s(default %s) " + prompt deffile) + prompt) + defdir + (concat defdir deffile) + mustmatch-p))) + (list (expand-file-name (substitute-in-file-name ans))))) + +;; I am somewhat divided on this string-default feature. It seems +;; to violate the principle-of-least-astonishment, in that it makes +;; the default harder to predict, so you actually have to look and see +;; what the default really is before choosing it. This can trip you up. +;; On the other hand, it can be useful, I guess. I would appreciate feedback +;; on this. +;; -Olin + + +;; Simple process query facility. +;; =========================================================================== +;; This function is for commands that want to send a query to the process +;; and show the response to the user. For example, a command to get the +;; arglist for a Common Lisp function might send a "(arglist 'foo)" query +;; to an inferior Common Lisp process. +;; +;; This simple facility just sends strings to the inferior process and pops +;; up a window for the process buffer so you can see what the process +;; responds with. We don't do anything fancy like try to intercept what the +;; process responds with and put it in a pop-up window or on the message +;; line. We just display the buffer. Low tech. Simple. Works good. + +;; Send to the inferior process PROC the string STR. Pop-up but do not select +;; a window for the inferior process so that its response can be seen. +(defun comint-proc-query (proc str) + (let* ((proc-buf (process-buffer proc)) + (proc-mark (process-mark proc))) + (display-buffer proc-buf) + (set-buffer proc-buf) ; but it's not the selected *window* + (let ((proc-win (get-buffer-window proc-buf)) + (proc-pt (marker-position proc-mark))) + (comint-send-string proc str) ; send the query + (accept-process-output proc) ; wait for some output + ;; Try to position the proc window so you can see the answer. + ;; This is bogus code. If you delete the (sit-for 0), it breaks. + ;; I don't know why. Wizards invited to improve it. + (unless (pos-visible-in-window-p proc-pt proc-win) + (let ((opoint (window-point proc-win))) + (set-window-point proc-win proc-mark) + (sit-for 0) + (if (not (pos-visible-in-window-p opoint proc-win)) + (push-mark opoint) + (set-window-point proc-win opoint))))))) + + +;; Filename/command/history completion in a buffer +;; =========================================================================== +;; Useful completion functions, courtesy of the Ergo group. + +;; Six commands: +;; comint-dynamic-complete Complete or expand command, filename, +;; history at point. +;; comint-dynamic-complete-filename Complete filename at point. +;; comint-dynamic-list-filename-completions List completions in help buffer. +;; comint-replace-by-expanded-filename Expand and complete filename at point; +;; replace with expanded/completed name. +;; comint-dynamic-simple-complete Complete stub given candidates. + +;; These are not installed in the comint-mode keymap. But they are +;; available for people who want them. Shell-mode installs them: +;; (define-key shell-mode-map "\t" 'comint-dynamic-complete) +;; (define-key shell-mode-map "\M-?" +;; 'comint-dynamic-list-filename-completions))) +;; +;; Commands like this are fine things to put in load hooks if you +;; want them present in specific modes. + +(defcustom comint-completion-autolist nil + "*If non-nil, automatically list possibilities on partial completion. +This mirrors the optional behavior of tcsh." + :type 'boolean + :group 'comint-completion) + +(defcustom comint-completion-addsuffix t + "*If non-nil, add a `/' to completed directories, ` ' to file names. +If a cons pair, it should be of the form (DIRSUFFIX . FILESUFFIX) where +DIRSUFFIX and FILESUFFIX are strings added on unambiguous or exact completion. +This mirrors the optional behavior of tcsh." + :type '(choice (const :tag "None" nil) + (const :tag "Add /" t) + (cons :tag "Suffix pair" + (string :tag "Directory suffix") + (string :tag "File suffix"))) + :group 'comint-completion) + +(defcustom comint-completion-recexact nil + "*If non-nil, use shortest completion if characters cannot be added. +This mirrors the optional behavior of tcsh. + +A non-nil value is useful if `comint-completion-autolist' is non-nil too." + :type 'boolean + :group 'comint-completion) + +(defcustom comint-completion-fignore nil + "*List of suffixes to be disregarded during file completion. +This mirrors the optional behavior of bash and tcsh. + +Note that this applies to `comint-dynamic-complete-filename' only." + :type '(repeat (string :tag "Suffix")) + :group 'comint-completion) + +(defvar comint-file-name-prefix "" + "Prefix prepended to absolute file names taken from process input. +This is used by comint's and shell's completion functions, and by shell's +directory tracking functions.") + +(defvar comint-file-name-chars + (if (memq system-type '(ms-dos windows-nt)) + "~/A-Za-z0-9_^$!#%&{}@`'.,:()-" + "~/A-Za-z0-9+@:_.$#%,={}-") + "String of characters valid in a file name. +Note that all non-ASCII characters are considered valid in a file name +regardless of what this variable says. + +This is a good thing to set in mode hooks.") + +(defvar comint-file-name-quote-list nil + "List of characters to quote with `\\' when in a file name. + +This is a good thing to set in mode hooks.") + + +(defun comint-directory (directory) + ;; Return expanded DIRECTORY, with `comint-file-name-prefix' if absolute. + (expand-file-name (if (file-name-absolute-p directory) + (concat comint-file-name-prefix directory) + directory))) + + +(defun comint-word (word-chars) + "Return the word of WORD-CHARS at point, or nil if non is found. +Word constituents are considered to be those in WORD-CHARS, which is like the +inside of a \"[...]\" (see `skip-chars-forward'), +plus all non-ASCII characters." + (save-excursion + (let ((non-word-chars (concat "[^\\\\" word-chars "]")) (here (point))) + (while (and (re-search-backward non-word-chars nil 'move) + ;;(memq (char-after (point)) shell-file-name-quote-list) + (or (>= (following-char) 128) + (eq (preceding-char) ?\\))) + (backward-char 1)) + ;; Don't go forward over a word-char (this can happen if we're at bob). + (when (or (not (bobp)) (looking-at non-word-chars)) + (forward-char 1)) + ;; Set match-data to match the entire string. + (when (< (point) here) + (set-match-data (list (point) here)) + (match-string 0))))) + +(defun comint-substitute-in-file-name (filename) + "Return FILENAME with environment variables substituted. +Supports additional environment variable syntax of the command +interpreter (e.g., the percent notation of cmd.exe on NT)." + (let ((name (substitute-in-file-name filename))) + (if (memq system-type '(ms-dos windows-nt)) + (let (env-var-name + env-var-val) + (save-match-data + (while (string-match "%\\([^\\\\/]*\\)%" name) + (setq env-var-name + (substring name (match-beginning 1) (match-end 1))) + (setq env-var-val (if (getenv env-var-name) + (getenv env-var-name) + "")) + (setq name (replace-match env-var-val t t name)))))) + name)) + +(defun comint-match-partial-filename () + "Return the filename at point, or nil if non is found. +Environment variables are substituted. See `comint-word'." + (let ((filename (comint-word comint-file-name-chars))) + (and filename (comint-substitute-in-file-name + (comint-unquote-filename filename))))) + + +(defun comint-quote-filename (filename) + "Return FILENAME with magic characters quoted. +Magic characters are those in `comint-file-name-quote-list'." + (if (null comint-file-name-quote-list) + filename + (let ((regexp + (format "\\(^\\|[^\\]\\)\\([%s]\\)" + (mapconcat 'char-to-string comint-file-name-quote-list "")))) + (save-match-data + (while (string-match regexp filename) + (setq filename (replace-match "\\1\\\\\\2" nil nil filename))) + filename)))) + +(defun comint-unquote-filename (filename) + "Return FILENAME with quoted characters unquoted." + (if (null comint-file-name-quote-list) + filename + (save-match-data + (let ((i 0)) + (while (string-match "\\\\\\(.\\)" filename i) + (setq filename (replace-match "\\1" nil nil filename)) + (setq i (+ 1 (match-beginning 0))))) + filename))) + + +(defun comint-dynamic-complete () + "Dynamically perform completion at point. +Calls the functions in `comint-dynamic-complete-functions' to perform +completion until a function returns non-nil, at which point completion is +assumed to have occurred." + (interactive) + (run-hook-with-args-until-success 'comint-dynamic-complete-functions)) + + +(defun comint-dynamic-complete-filename () + "Dynamically complete the filename at point. +Completes if after a filename. See `comint-match-partial-filename' and +`comint-dynamic-complete-as-filename'. +This function is similar to `comint-replace-by-expanded-filename', except that +it won't change parts of the filename already entered in the buffer; it just +adds completion characters to the end of the filename. A completions listing +may be shown in a help buffer if completion is ambiguous. + +Completion is dependent on the value of `comint-completion-addsuffix', +`comint-completion-recexact' and `comint-completion-fignore', and the timing of +completions listing is dependent on the value of `comint-completion-autolist'. + +Returns t if successful." + (interactive) + (when (comint-match-partial-filename) + (unless (window-minibuffer-p (selected-window)) + (message "Completing file name...")) + (comint-dynamic-complete-as-filename))) + +(defun comint-dynamic-complete-as-filename () + "Dynamically complete at point as a filename. +See `comint-dynamic-complete-filename'. Returns t if successful." + (let* ((completion-ignore-case (memq system-type '(ms-dos windows-nt))) + (completion-ignored-extensions comint-completion-fignore) + ;; If we bind this, it breaks remote directory tracking in rlogin.el. + ;; I think it was originally bound to solve file completion problems, + ;; but subsequent changes may have made this unnecessary. sm. + ;;(file-name-handler-alist nil) + (minibuffer-p (window-minibuffer-p (selected-window))) + (success t) + (dirsuffix (cond ((not comint-completion-addsuffix) + "") + ((not (consp comint-completion-addsuffix)) + (char-to-string directory-sep-char)) + (t + (car comint-completion-addsuffix)))) + (filesuffix (cond ((not comint-completion-addsuffix) + "") + ((not (consp comint-completion-addsuffix)) + " ") + (t + (cdr comint-completion-addsuffix)))) + (filename (or (comint-match-partial-filename) "")) + (pathdir (file-name-directory filename)) + (pathnondir (file-name-nondirectory filename)) + (directory (if pathdir (comint-directory pathdir) default-directory)) + (completion (file-name-completion pathnondir directory))) + (cond ((null completion) + (message "No completions of %s" filename) + (setq success nil)) + ((eq completion t) ; Means already completed "file". + (insert filesuffix) + (unless minibuffer-p + (message "Sole completion"))) + ((string-equal completion "") ; Means completion on "directory/". + (comint-dynamic-list-filename-completions)) + (t ; Completion string returned. + (let ((file (concat (file-name-as-directory directory) completion))) + (insert (comint-quote-filename + (substring (directory-file-name completion) + (length pathnondir)))) + (cond ((symbolp (file-name-completion completion directory)) + ;; We inserted a unique completion. + (insert (if (file-directory-p file) dirsuffix filesuffix)) + (unless minibuffer-p + (message "Completed"))) + ((and comint-completion-recexact comint-completion-addsuffix + (string-equal pathnondir completion) + (file-exists-p file)) + ;; It's not unique, but user wants shortest match. + (insert (if (file-directory-p file) dirsuffix filesuffix)) + (unless minibuffer-p + (message "Completed shortest"))) + ((or comint-completion-autolist + (string-equal pathnondir completion)) + ;; It's not unique, list possible completions. + (comint-dynamic-list-filename-completions)) + (t + (unless minibuffer-p + (message "Partially completed"))))))) + success)) + + +(defun comint-replace-by-expanded-filename () + "Dynamically expand and complete the filename at point. +Replace the filename with an expanded, canonicalised and completed replacement. +\"Expanded\" means environment variables (e.g., $HOME) and `~'s are replaced +with the corresponding directories. \"Canonicalised\" means `..' and `.' are +removed, and the filename is made absolute instead of relative. For expansion +see `expand-file-name' and `substitute-in-file-name'. For completion see +`comint-dynamic-complete-filename'." + (interactive) + (replace-match (expand-file-name (comint-match-partial-filename)) t t) + (comint-dynamic-complete-filename)) + + +(defun comint-dynamic-simple-complete (stub candidates) + "Dynamically complete STUB from CANDIDATES list. +This function inserts completion characters at point by completing STUB from +the strings in CANDIDATES. A completions listing may be shown in a help buffer +if completion is ambiguous. + +Returns nil if no completion was inserted. +Returns `sole' if completed with the only completion match. +Returns `shortest' if completed with the shortest of the completion matches. +Returns `partial' if completed as far as possible with the completion matches. +Returns `listed' if a completion listing was shown. + +See also `comint-dynamic-complete-filename'." + (let* ((completion-ignore-case (memq system-type '(ms-dos windows-nt))) + (suffix (cond ((not comint-completion-addsuffix) "") + ((not (consp comint-completion-addsuffix)) " ") + (t (cdr comint-completion-addsuffix)))) + (candidates (mapcar (function (lambda (x) (list x))) candidates)) + (completions (all-completions stub candidates))) + (cond ((null completions) + (message "No completions of %s" stub) + nil) + ((= 1 (length completions)) ; Gotcha! + (let ((completion (car completions))) + (if (string-equal completion stub) + (message "Sole completion") + (insert (substring completion (length stub))) + (message "Completed")) + (insert suffix) + 'sole)) + (t ; There's no unique completion. + (let ((completion (try-completion stub candidates))) + ;; Insert the longest substring. + (insert (substring completion (length stub))) + (cond ((and comint-completion-recexact comint-completion-addsuffix + (string-equal stub completion) + (member completion completions)) + ;; It's not unique, but user wants shortest match. + (insert suffix) + (message "Completed shortest") + 'shortest) + ((or comint-completion-autolist + (string-equal stub completion)) + ;; It's not unique, list possible completions. + (comint-dynamic-list-completions completions) + 'listed) + (t + (message "Partially completed") + 'partial))))))) + + +(defun comint-dynamic-list-filename-completions () + "List in help buffer possible completions of the filename at point." + (interactive) + (let* ((completion-ignore-case (memq system-type '(ms-dos windows-nt))) + ;; If we bind this, it breaks remote directory tracking in rlogin.el. + ;; I think it was originally bound to solve file completion problems, + ;; but subsequent changes may have made this unnecessary. sm. + ;;(file-name-handler-alist nil) + (filename (or (comint-match-partial-filename) "")) + (pathdir (file-name-directory filename)) + (pathnondir (file-name-nondirectory filename)) + (directory (if pathdir (comint-directory pathdir) default-directory)) + (completions (file-name-all-completions pathnondir directory))) + (if (not completions) + (message "No completions of %s" filename) + (comint-dynamic-list-completions + (mapcar 'comint-quote-filename completions))))) + + +(defun comint-dynamic-list-completions (completions) + "List in help buffer sorted COMPLETIONS. +Typing SPC flushes the help buffer." + (let ((conf (current-window-configuration))) + (with-output-to-temp-buffer "*Completions*" + (display-completion-list (sort completions 'string-lessp))) + (message "Hit space to flush") + (let (key first) + (if (save-excursion + (set-buffer (get-buffer "*Completions*")) + (setq key (read-key-sequence nil) + first (aref key 0)) + (and (consp first) (consp (event-start first)) + (eq (window-buffer (posn-window (event-start first))) + (get-buffer "*Completions*")) + (eq (key-binding key) 'mouse-choose-completion))) + ;; If the user does mouse-choose-completion with the mouse, + ;; execute the command, then delete the completion window. + (progn + (mouse-choose-completion first) + (set-window-configuration conf)) + (if (eq first ?\ ) + (set-window-configuration conf) + (setq unread-command-events (listify-key-sequence key))))))) + +(defun comint-get-next-from-history () + "After fetching a line from input history, this fetches the following line. +In other words, this recalls the input line after the line you recalled last. +You can use this to repeat a sequence of input lines." + (interactive) + (if comint-save-input-ring-index + (progn + (setq comint-input-ring-index (1+ comint-save-input-ring-index)) + (comint-next-input 1)) + (message "No previous history command"))) + +(defun comint-accumulate () + "Accumulate a line to send as input along with more lines. +This inserts a newline so that you can enter more text +to be sent along with this line. Use \\[comint-send-input] +to send all the accumulated input, at once. +The entire accumulated text becomes one item in the input history +when you send it." + (interactive) + (insert "\n") + (set-marker comint-accum-marker (point)) + (if comint-input-ring-index + (setq comint-save-input-ring-index + (- comint-input-ring-index 1)))) + +(defun comint-goto-process-mark () + "Move point to the process mark. +The process mark separates output, and input already sent, +from input that has not yet been sent." + (interactive) + (let ((proc (or (get-buffer-process (current-buffer)) + (error "Current buffer has no process")))) + (goto-char (process-mark proc)) + (when (interactive-p) + (message "Point is now at the process mark")))) + +(defun comint-bol-or-process-mark () + "Move point to beginning of line (after prompt) or to the process mark. +The first time you use this command, it moves to the beginning of the line +\(but after the prompt, if any). If you repeat it again immediately, +it moves point to the process mark. + +The process mark separates the process output, along with input already sent, +from input that has not yet been sent. Ordinarily, the process mark +is at the beginning of the current input line; but if you have +used \\[comint-accumulate] to send multiple lines at once, +the process mark is at the beginning of the accumulated input." + (interactive) + (if (not (eq last-command 'comint-bol-or-process-mark)) + (comint-bol nil) + (comint-goto-process-mark))) + +(defun comint-set-process-mark () + "Set the process mark at point." + (interactive) + (let ((proc (or (get-buffer-process (current-buffer)) + (error "Current buffer has no process")))) + (set-marker (process-mark proc) (point)) + (message "Process mark set"))) + + +;; Author: Peter Breton + +;; This little add-on for comint is intended to make it easy to get +;; output from currently active comint buffers into another buffer, +;; or buffers, and then go back to using the comint shell. +;; +;; My particular use is SQL interpreters; I want to be able to execute a +;; query using the process associated with a comint-buffer, and save that +;; somewhere else. Because the process might have state (for example, it +;; could be in an uncommitted transaction), just running starting a new +;; process and having it execute the query and then finish, would not +;; work. I'm sure there are other uses as well, although in many cases +;; starting a new process is the simpler, and thus preferable, approach. +;; +;; The basic implementation is as follows: comint-redirect changes the +;; preoutput filter functions (comint-preoutput-filter-functions) to use +;; its own filter. The filter puts the output into the designated buffer, +;; or buffers, until it sees a regexp that tells it to stop (by default, +;; this is the prompt for the interpreter, comint-prompt-regexp). When it +;; sees the stop regexp, it restores the old filter functions, and runs +;; comint-redirect-hook. +;; +;; Each comint buffer may only use one redirection at a time, but any number +;; of different comint buffers may be simultaneously redirected. +;; +;; NOTE: It is EXTREMELY important that `comint-prompt-regexp' be set to the +;; correct prompt for your interpreter, or that you supply a regexp that says +;; when the redirection is finished. Otherwise, redirection will continue +;; indefinitely. The code now does a sanity check to ensure that it can find +;; a prompt in the comint buffer; however, it is still important to ensure that +;; this prompt is set correctly. +;; +;; XXX: This doesn't work so well unless comint-prompt-regexp is set; +;; perhaps it should prompt for a terminating string (with an +;; appropriate magic default by examining what we think is the prompt)? +;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Variables +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defcustom comint-redirect-verbose nil + "*If non-nil, print messages each time the redirection filter is invoked. +Also print a message when redirection is completed." + :group 'comint + :type 'boolean) + +;; Directly analagous to comint-preoutput-filter-functions +(defvar comint-redirect-filter-functions nil + "List of functions to call before inserting redirected process output. +Each function gets one argument, a string containing the text received +from the subprocess. It should return the string to insert, perhaps +the same string that was received, or perhaps a modified or transformed +string. + +The functions on the list are called sequentially, and each one is given +the string returned by the previous one. The string returned by the +last function is the text that is actually inserted in the redirection buffer.") + +(make-variable-buffer-local 'comint-redirect-filter-functions) + +;; Internal variables + +(defvar comint-redirect-output-buffer nil + "The buffer or list of buffers to put output into.") + +(defvar comint-redirect-finished-regexp nil + "Regular expression that determines when to stop redirection in Comint. +When the redirection filter function is given output that matches this regexp, +the output is inserted as usual, and redirection is completed.") + +(defvar comint-redirect-insert-matching-regexp nil + "If non-nil, the text that ends a redirection is included in it. +More precisely, the text that matches `comint-redirect-finished-regexp' +and therefore terminates an output redirection is inserted in the +redirection target buffer, along with the preceding output.") + +(defvar comint-redirect-echo-input nil + "Non-nil means echo input in the process buffer even during redirection.") + +(defvar comint-redirect-completed nil + "Non-nil if redirection has completed in the current buffer.") + +(defvar comint-redirect-original-mode-line-process nil + "Original mode line for redirected process.") + +(defvar comint-redirect-perform-sanity-check t + "If non-nil, check that redirection is likely to complete successfully. +More precisely, before starting a redirection, verify that the +regular expression `comint-redirect-finished-regexp' that controls +when to terminate it actually matches some text already in the process +buffer. The idea is that this regular expression should match a prompt +string, and that there ought to be at least one copy of your prompt string +in the process buffer already.") + +(defvar comint-redirect-original-filter-function nil + "The process filter that was in place when redirection is started. +When redirection is completed, the process filter is restored to +this value.") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Functions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun comint-redirect-setup (output-buffer + comint-buffer + finished-regexp + &optional echo-input) + "Set up for output redirection. +This function sets local variables that are used by `comint-redirect-filter' +to perform redirection. + +Output from COMINT-BUFFER is redirected to OUTPUT-BUFFER, until something +in the output matches FINISHED-REGEXP. + +If optional argument ECHO-INPUT is non-nil, output is echoed to the +original comint buffer. + +This function is called by `comint-redirect-send-command-to-process', +and does not normally need to be invoked by the end user or programmer." + (with-current-buffer comint-buffer + + (make-local-variable 'comint-redirect-original-mode-line-process) + (setq comint-redirect-original-mode-line-process mode-line-process) + + (make-local-variable 'comint-redirect-output-buffer) + (setq comint-redirect-output-buffer output-buffer) + + (make-local-variable 'comint-redirect-finished-regexp) + (setq comint-redirect-finished-regexp finished-regexp) + + (make-local-variable 'comint-redirect-echo-input) + (setq comint-redirect-echo-input echo-input) + + (make-local-variable 'comint-redirect-completed) + (setq comint-redirect-completed nil) + + (setq mode-line-process + (if mode-line-process + (list (concat (elt mode-line-process 0) " Redirection")) + (list ":%s Redirection"))))) + +(defun comint-redirect-cleanup () + "End a Comint redirection. See `comint-redirect-send-command'." + (interactive) + ;; Restore the process filter + (set-process-filter (get-buffer-process (current-buffer)) + comint-redirect-original-filter-function) + ;; Restore the mode line + (setq mode-line-process comint-redirect-original-mode-line-process) + ;; Set the completed flag + (setq comint-redirect-completed t)) + +;; Because the cleanup happens as a callback, it's not easy to guarantee +;; that it really occurs. +(defalias 'comint-redirect-remove-redirection 'comint-redirect-cleanup) + +(defun comint-redirect-filter (process input-string) + "Filter function which redirects output from PROCESS to a buffer or buffers. +The variable `comint-redirect-output-buffer' says which buffer(s) to +place output in. + +INPUT-STRING is the input from the comint process. + +This function runs as a process filter, and does not need to be invoked by the +end user." + (and process + (with-current-buffer (process-buffer process) + (comint-redirect-preoutput-filter input-string) + ;; If we have to echo output, give it to the original filter function + (and comint-redirect-echo-input + comint-redirect-original-filter-function + (funcall comint-redirect-original-filter-function + process input-string))))) + + +(defun comint-redirect-preoutput-filter (input-string) + "Comint filter function which redirects comint output to a buffer or buffers. +The variable `comint-redirect-output-buffer' says which buffer(s) to +place output in. + +INPUT-STRING is the input from the comint process. + +This function does not need to be invoked by the end user." + (let ((output-buffer-list + (if (listp comint-redirect-output-buffer) + comint-redirect-output-buffer + (list comint-redirect-output-buffer))) + (filtered-input-string input-string)) + + ;; If there are any filter functions, give them a chance to modify the string + (let ((functions comint-redirect-filter-functions)) + (while (and functions filtered-input-string) + (setq filtered-input-string + (funcall (car functions) filtered-input-string)) + (setq functions (cdr functions)))) + + ;; Clobber `comint-redirect-finished-regexp' + (or comint-redirect-insert-matching-regexp + (and (string-match comint-redirect-finished-regexp filtered-input-string) + (setq filtered-input-string + (replace-match "" nil nil filtered-input-string)))) + + ;; Send output to all registered buffers + (save-excursion + (mapcar + (function (lambda(buf) + ;; Set this buffer to the output buffer + (set-buffer (get-buffer-create buf)) + ;; Go to the end of the buffer + (goto-char (point-max)) + ;; Insert the output + (insert filtered-input-string))) + output-buffer-list)) + + ;; Message + (and comint-redirect-verbose + (message "Redirected output to buffer(s) %s" + (mapconcat 'identity output-buffer-list " "))) + + ;; If we see the prompt, tidy up + ;; We'll look for the prompt in the original string, so nobody can + ;; clobber it + (and (string-match comint-redirect-finished-regexp input-string) + (progn + (and comint-redirect-verbose + (message "Redirection completed")) + (comint-redirect-cleanup) + (run-hooks 'comint-redirect-hook))) + ;; Echo input? + (if comint-redirect-echo-input + filtered-input-string + ""))) + +;;;###autoload +(defun comint-redirect-send-command (command output-buffer echo &optional no-display) + "Send COMMAND to process in current buffer, with output to OUTPUT-BUFFER. +With prefix arg, echo output in process buffer. + +If NO-DISPLAY is non-nil, do not show the output buffer." + (interactive "sCommand: \nBOutput Buffer: \nP") + (let ((process (get-buffer-process (current-buffer)))) + (if process + (comint-redirect-send-command-to-process + command output-buffer (current-buffer) echo no-display) + (error "No process for current buffer")))) + +;;;###autoload +(defun comint-redirect-send-command-to-process + (command output-buffer process echo &optional no-display) + "Send COMMAND to PROCESS, with output to OUTPUT-BUFFER. +With prefix arg, echo output in process buffer. + +If NO-DISPLAY is non-nil, do not show the output buffer." + (interactive "sCommand: \nBOutput Buffer: \nbProcess Buffer: \nP") + (let* (;; The process buffer + (process-buffer (if (processp process) + (process-buffer process) + process)) + (proc (get-buffer-process process-buffer))) + ;; Change to the process buffer + (set-buffer process-buffer) + + ;; Make sure there's a prompt in the current process buffer + (and comint-redirect-perform-sanity-check + (save-excursion + (goto-char (point-max)) + (or (re-search-backward comint-prompt-regexp nil t) + (error "No prompt found or `comint-prompt-regexp' not set properly")))) + + ;;;;;;;;;;;;;;;;;;;;; + ;; Set up for redirection + ;;;;;;;;;;;;;;;;;;;;; + (comint-redirect-setup + ;; Output Buffer + output-buffer + ;; Comint Buffer + (current-buffer) + ;; Finished Regexp + comint-prompt-regexp + ;; Echo input + echo) + + ;;;;;;;;;;;;;;;;;;;;; + ;; Set the filter + ;;;;;;;;;;;;;;;;;;;;; + ;; Save the old filter + (setq comint-redirect-original-filter-function + (process-filter proc)) + (set-process-filter proc 'comint-redirect-filter) + + ;;;;;;;;;;;;;;;;;;;;; + ;; Send the command + ;;;;;;;;;;;;;;;;;;;;; + (process-send-string + (current-buffer) + (concat command "\n")) + + ;;;;;;;;;;;;;;;;;;;;; + ;; Show the output + ;;;;;;;;;;;;;;;;;;;;; + (or no-display + (display-buffer + (get-buffer-create + (if (listp output-buffer) + (car output-buffer) + output-buffer)))))) + +;;;###autoload +(defun comint-redirect-results-list (command regexp regexp-group) + "Send COMMAND to current process. +Return a list of expressions in the output which match REGEXP. +REGEXP-GROUP is the regular expression group in REGEXP to use." + (comint-redirect-results-list-from-process + (get-buffer-process (current-buffer)) + command regexp regexp-group)) + +;;;###autoload +(defun comint-redirect-results-list-from-process (process command regexp regexp-group) + "Send COMMAND to PROCESS. +Return a list of expressions in the output which match REGEXP. +REGEXP-GROUP is the regular expression group in REGEXP to use." + (let ((output-buffer " *Comint Redirect Work Buffer*") + results) + (save-excursion + (set-buffer (get-buffer-create output-buffer)) + (erase-buffer) + (comint-redirect-send-command-to-process command + output-buffer process nil t) + ;; Wait for the process to complete + (set-buffer (process-buffer process)) + (while (null comint-redirect-completed) + (accept-process-output nil 1)) + ;; Collect the output + (set-buffer output-buffer) + (goto-char (point-min)) + ;; Skip past the command, if it was echoed + (and (looking-at command) + (forward-line)) + (while (re-search-forward regexp nil t) + (setq results + (cons (buffer-substring-no-properties + (match-beginning regexp-group) + (match-end regexp-group)) + results))) + results))) + +(mapc (lambda (x) + (add-to-list 'debug-ignored-errors x)) + '("^Not at command line$" + "^Empty input ring$" + "^No history$" + "^Not found$" ; Too common? + "^Current buffer has no process$")) + +;; Converting process modes to use comint mode +;; =========================================================================== +;; The code in the Emacs 19 distribution has all been modified to use comint +;; where needed. However, there are `third-party' packages out there that +;; still use the old shell mode. Here's a guide to conversion. +;; +;; Renaming variables +;; Most of the work is renaming variables and functions. These are the common +;; ones: +;; Local variables: +;; last-input-start comint-last-input-start +;; last-input-end comint-last-input-end +;; shell-prompt-pattern comint-prompt-regexp +;; shell-set-directory-error-hook +;; Miscellaneous: +;; shell-set-directory +;; shell-mode-map comint-mode-map +;; Commands: +;; shell-send-input comint-send-input +;; shell-send-eof comint-delchar-or-maybe-eof +;; kill-shell-input comint-kill-input +;; interrupt-shell-subjob comint-interrupt-subjob +;; stop-shell-subjob comint-stop-subjob +;; quit-shell-subjob comint-quit-subjob +;; kill-shell-subjob comint-kill-subjob +;; kill-output-from-shell comint-delete-output +;; show-output-from-shell comint-show-output +;; copy-last-shell-input Use comint-previous-input/comint-next-input +;; +;; SHELL-SET-DIRECTORY is gone, its functionality taken over by +;; SHELL-DIRECTORY-TRACKER, the shell mode's comint-input-filter-functions. +;; Comint mode does not provide functionality equivalent to +;; shell-set-directory-error-hook; it is gone. +;; +;; comint-last-input-start is provided for modes which want to munge +;; the buffer after input is sent, perhaps because the inferior +;; insists on echoing the input. The LAST-INPUT-START variable in +;; the old shell package was used to implement a history mechanism, +;; but you should think twice before using comint-last-input-start +;; for this; the input history ring often does the job better. +;; +;; If you are implementing some process-in-a-buffer mode, called foo-mode, do +;; *not* create the comint-mode local variables in your foo-mode function. +;; This is not modular. Instead, call comint-mode, and let *it* create the +;; necessary comint-specific local variables. Then create the +;; foo-mode-specific local variables in foo-mode. Set the buffer's keymap to +;; be foo-mode-map, and its mode to be foo-mode. Set the comint-mode hooks +;; (comint-{prompt-regexp, input-filter, input-filter-functions, +;; get-old-input) that need to be different from the defaults. Call +;; foo-mode-hook, and you're done. Don't run the comint-mode hook yourself; +;; comint-mode will take care of it. The following example, from shell.el, +;; is typical: +;; +;; (defvar shell-mode-map '()) +;; (cond ((not shell-mode-map) +;; (setq shell-mode-map (copy-keymap comint-mode-map)) +;; (define-key shell-mode-map "\C-c\C-f" 'shell-forward-command) +;; (define-key shell-mode-map "\C-c\C-b" 'shell-backward-command) +;; (define-key shell-mode-map "\t" 'comint-dynamic-complete) +;; (define-key shell-mode-map "\M-?" +;; 'comint-dynamic-list-filename-completions))) +;; +;; (defun shell-mode () +;; (interactive) +;; (comint-mode) +;; (setq comint-prompt-regexp shell-prompt-pattern) +;; (setq major-mode 'shell-mode) +;; (setq mode-name "Shell") +;; (use-local-map shell-mode-map) +;; (make-local-variable 'shell-directory-stack) +;; (setq shell-directory-stack nil) +;; (add-hook 'comint-input-filter-functions 'shell-directory-tracker) +;; (run-hooks 'shell-mode-hook)) +;; +;; +;; Completion for comint-mode users +;; +;; For modes that use comint-mode, comint-dynamic-complete-functions is the +;; hook to add completion functions to. Functions on this list should return +;; non-nil if completion occurs (i.e., further completion should not occur). +;; You could use comint-dynamic-simple-complete to do the bulk of the +;; completion job. + +(provide 'comint) + +;;; comint.el ends here hunk ./site-lisp/guileint-1.5/defmenu.el 1 +;;; @(#) defmenu.el -- A GNU Emacs extension which helps building menus +;;; @(#) $Keywords: X, menu $ + +;; Copyright (C) 1995 Mikael Djurfeldt + +;; LCD Archive Entry: +;; defmenu|djurfeldt@nada.kth.se| +;; A GNU Emacs extension which helps building menus| +;; $Date: 1996/10/15 14:58:24 $|$Revision: 1.1 $|~/misc/defmenu.el.Z| + +;; Author: Mikael Djurfeldt +;; Version: 1.0 + +;; This program is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by the Free +;; Software Foundation; either version 2 of the License, or (at your option) +;; any later version. +;; +;; This program 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 General Public License +;; for more details. +;; +;; You should have received a copy of the GNU General Public License along +;; with GNU Emacs. If you did not, write to the Free Software Foundation, +;; Inc., 675 Mass Ave., Cambridge, MA 02139, USA. + +;;; Commentary: +;; +;; Requirements: +;; +;; Usage: +;; +;; Bugs: +;; +;; + +(defun define-menu (keymap key name entries) + "Define a menu in KEYMAP on fake function key KEY with label NAME. +Every entry in the list ENTRIES defines a menu item and looks like this: + + (LABEL DEFINITION [ENABLE-EXP]) + +LABEL is a string which will appear in the menu. +DEFINITION is either a symbol, in which case it will be used both as +fake function key and binding, or a pair, where the car is the fake +function key and the cdr is the binding. +The optional ENABLE-EXP is an expression which will be evaluated every +time the menu is displayed. If it returns nil the menu item will +be disabled. + +You can get a separator by including nil in the ENTRIES list." + (define-key keymap + (vector 'menu-bar key) + (cons name (make-menu name entries)))) + +(defun make-menu (name entries) + "Make a menu with label NAME. +Every entry in the list ENTRIES defines a menu item and looks like this: + + (LABEL DEFINITION [ENABLE-EXP]) + +LABEL is a string which will appear in the menu. +DEFINITION is either a symbol, in which case it will be used both as +fake function key and binding, or a pair, where the car is the fake +function key and the cdr is the binding. +The optional ENABLE-EXP is an expression which will be evaluated every +time the menu is displayed. If it returns nil the menu item will +be disabled. + +You can get a separator by including nil in the ENTRIES list." + (let ((menu (make-sparse-keymap name)) + (entries (reverse entries))) + (while entries + (let ((entry (car entries))) + (if (null entry) + (define-key menu (vector (defmenu-gensym "separator")) '("--")) + (if (symbolp (nth 1 entry)) + (define-key menu (vector (nth 1 entry)) + (cons (car entry) (nth 1 entry))) + (define-key menu (vector (car (nth 1 entry))) + (cons (car entry) (cdr (nth 1 entry))))) + (if (not (null (nthcdr 2 entry))) + (put (nth 1 entry) 'menu-enable (nth 2 entry))))) + (setq entries (cdr entries))) + menu)) + +(defun defmenu-gensym (prefix) + (let ((counter (intern (concat "defmenu-" prefix "count")))) + (if (boundp counter) (set counter (1+ (symbol-value counter))) + (set counter 0)) + (intern (concat prefix (int-to-string (symbol-value counter)))))) + +(provide 'defmenu) hunk ./site-lisp/guileint-1.5/fcreate.el 1 +(defun lookup-face-create (face &optional force) + "Get a FACE, or create it if it doesn't exist. In order for it to +properly create the face, the following naming convention must be used: + [reverse-](fgcolor[/bgcolor])[-bold][-italic][-underline] + +Each color is either the name of an X color (see .../X11/lib/X11/rgb.txt), +a hexadecimal specification of the form \"hex-[0-9A-Fa-f]+\", or \"default\". + +An optional argument, FORCE, will cause the face to be recopied from the +default...which is probably of use only if you've changed fonts." + + ;; make the face if we need to... + (let* ((fn (symbol-name face)) + (frame (selected-frame)) + (basefont (cdr (assq 'font (frame-parameters frame)))) + error fgcolor bgcolor) + (cond + ((or (null face) + ;;(memq face hilit-predefined-face-list) + ) + ;; do nothing if the face is nil or if it's predefined. + ) + ((or force + (not (memq face (face-list))) + (not (string= (get face 'basefont) basefont))) + (copy-face 'default 'scratch-face) + (if (string-match "^reverse-?" fn) + (progn (invert-face 'scratch-face) + (setq fn (substring fn (match-end 0))))) + + ;; parse foreground color + (if (string-match "^\\(hex-\\)?\\([A-Za-z0-9]+\\)" fn) + (setq fgcolor (concat + (if (match-beginning 1) "#") + (substring fn (match-beginning 2) (match-end 2))) + fn (substring fn (match-end 0))) + (error "bad face name %S" face)) + + ;; parse background color + (if (string-match "^/\\(hex-\\)?\\([A-Za-z0-9]+\\)" fn) + (setq bgcolor (concat + (and (match-beginning 1) "#") + (substring fn (match-beginning 2) (match-end 2))) + fn (substring fn (match-end 0)))) + + (and (string= "default" fgcolor) (setq fgcolor nil)) + (and (string= "default" bgcolor) (setq bgcolor nil)) + + ;; catch errors if we can't allocate the color(s) + (condition-case nil + (progn (set-face-foreground 'scratch-face fgcolor) + (set-face-background 'scratch-face bgcolor) + (copy-face 'scratch-face face) + (put face 'basefont basefont)) + (error (message "couldn't allocate color for '%s'" + (symbol-name face)) + (setq face 'default) + (setq error t))) + (or error + ;; don't bother w/ bold or italic if we didn't get the color + ;; we wanted, but ignore errors making the face bold or italic + ;; if the font isn't available, there's nothing to do about it... + (progn + ;(set-face-font face nil frame) MDJ 020919 + (set-face-underline-p face (string-match "underline" fn)) + (if (string-match ".*bold" fn) + ;; make face bold in all frames + (make-face-bold face nil 'noerr)) + (if (string-match ".*italic" fn) + ;; make face italic in all frames + (make-face-italic face nil 'noerr)) + )) + ))) + face) + +(provide 'fcreate) hunk ./site-lisp/guileint-1.5/guess-mode.el 1 +;;; @(#) guess-mode.el -- Helps a novice select the right mode +;;; @(#) $Keywords: novice, mode $ + +;; Copyright (C) 1995 Mikael Djurfeldt + +;; LCD Archive Entry: +;; Helps a novice select the right mode|djurfeldt@nada.kth.se| +;; A GNU Emacs extension which | +;; $Date: 1996/11/06 19:51:42 $|$Revision: 1.2 $|~/misc/guess-mode.el.Z| + +;; Author: Mikael Djurfeldt +;; Version: 1.0 + +;; This program is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by the Free +;; Software Foundation; either version 2 of the License, or (at your option) +;; any later version. +;; +;; This program 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 General Public License +;; for more details. +;; +;; You should have received a copy of the GNU General Public License along +;; with GNU Emacs. If you did not, write to the Free Software Foundation, +;; Inc., 675 Mass Ave., Cambridge, MA 02139, USA. + +;;; Commentary: +;; +;; Requirements: +;; +;; Usage: +;; +;; Bugs: +;; +;; + +(defvar guess-mode-load-hook nil + "*Hook run when file is loaded") + +;; Validating the buffer mode... +;; +(defvar gm-check-contents-interval 20) + +(defvar gm-check-contents-maxsize 1000) + +(defvar gm-check-contents-tick-limit 0) +(make-variable-buffer-local 'gm-check-contents-tick-limit) + +(defvar gm-check-modes '(fundamental-mode lisp-interaction-mode)) + +(defvar gm-guess-mode-alist + '(("^(define" . scheme-mode) + ("^#include" . c-mode) + ("^[A-Za-z0-9_]+\\([ \t\n]+[A-Za-z0-9_]+\\)*[ \t\n]+(.*)[ \t\n]+{" . c-mode))) + +(defun gm-check-contents-hook-function () + (if gm-check-contents-tick-limit + (if (> (buffer-modified-tick) + gm-check-contents-tick-limit) + (gm-check-contents)))) + +(if (not (get 'gm-check-contents 'disabled)) + (run-with-idle-timer 2 (function gm-check-contents-hook-function))) + +(defun gm-check-contents () + (interactive) ; This is just to be able to use `disable-command'... + (if (not (memq major-mode gm-check-modes)) + (setq gm-check-contents-tick-limit nil) + (let ((guess (gm-guess-mode))) + (if (not guess) + (if (> (point-max) gm-check-contents-maxsize) + (setq gm-check-contents-tick-limit nil) + (setq gm-check-contents-tick-limit + (+ (buffer-modified-tick) gm-check-contents-interval))) + (if (not (eq guess major-mode)) + (let ((answer nil)) + (while (not answer) + (ding) + (setq answer + (x-popup-dialog + t + (list + (format + "It seems to me like you would like to edit in %s... +Am I right about this?" guess) + '("Yes" . yes) + ;nil - Can't have this due to an emacs bug... + '("No" . nix) + '("No, and never bother me again." . never-again))))) + (if (not (eq answer 'yes)) + (if (eq answer 'never) + (disable-command 'gm-check-contents)) + (funcall guess) + (sit-for 0) + (x-popup-dialog + t + (list + (format + "I have now switched to %s. To make this happen automatically +you should end the filename with %s." guess (gm-make-extension-string guess)) + '("OK" . t)))))) + (setq gm-check-contents-tick-limit nil))))) + +(defun gm-guess-mode () + (let ((alist gm-guess-mode-alist) + (guess nil)) + (save-excursion + (while alist + (goto-char (point-min)) + (if (re-search-forward (car (car alist)) + (+ (point-min) gm-check-contents-maxsize) + t) + (progn + (setq guess (cdr (car alist))) + (setq alist ())) + (setq alist (cdr alist))))) + guess)) + +(defconst gm-extension-regexp-regexp + "\\`\\\\\\(\\.[A-Za-z0-9+]+\\)\\\\\\('\\|\\$\\)\\'") + +(defun gm-make-extension-string (mode) + (let ((alist auto-mode-alist) + (extensions nil)) + (while alist + (if (and (if (consp (cdr (car alist))) + (eq (nth 1 (car alist)) mode) + (eq (cdr (car alist)) mode)) + (string-match gm-extension-regexp-regexp (car (car alist)))) + (setq extensions (cons (concat "\"" + (match-string 1 (car (car alist))) + "\"") + extensions))) + (setq alist (cdr alist))) + (gm-make-enumeration-string extensions "or"))) + +(defun gm-make-enumeration-string (items conjunction) + (let ((n (length items))) + (cond ((= n 1) (car items)) + ((= n 2) (concat (car items) " " conjunction " " (nth 1 items))) + (t + (let ((result (car items))) + (setq items (cdr items)) + (while (cdr items) + (setq result (concat result ", " (car items))) + (setq items (cdr items))) + (concat result " " conjunction " " (car items))))))) + +(provide 'guess-mode) +(run-hooks 'guess-mode-load-hook) hunk ./site-lisp/guileint-1.5/guile-init.el 1 +;;; @(#) guile-init.el -- +;;; @(#) $Keywords: $ + +;; Copyright (C) 1995 Mikael Djurfeldt + +;; LCD Archive Entry: +;; guile-init|djurfeldt@nada.kth.se| +;; A GNU Emacs extension which | +;; $Date: 1997/08/31 21:10:21 $|$Revision: 1.4 $|~/misc/.el.Z| + +;; Author: Mikael Djurfeldt +;; Version: 1.0 + +;; This program is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by the Free +;; Software Foundation; either version 2 of the License, or (at your option) +;; any later version. +;; +;; This program 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 General Public License +;; for more details. +;; +;; You should have received a copy of the GNU General Public License along +;; with GNU Emacs. If you did not, write to the Free Software Foundation, +;; Inc., 675 Mass Ave., Cambridge, MA 02139, USA. + +;;; Commentary: +;; +;; Requirements: +;; +;; Usage: +;; +;; Bugs: +;; +;; + +(defvar guile-init-load-hook nil + "*Hook run when file is loaded") + +(require 'guile) + +;;; Misc. interactivity +;;; +;;; +(defun inda-barf-at-modifications (&rest args) + (or inhibit-read-only + (error "Attempt to modify read-only text"))) + +(defun inda-boldify-previous-character () + ;; Must check this so that we don't point outside buffer... + (if (> (point) (point-min)) + (let ((inhibit-read-only t)) + (put-text-property (1- (point)) (point) 'face 'bold)))) + +(defun inda-make-input-memory (string) + ;; If input consists of many lines, the read-only overlay will + ;; cover the previous line, so we have to disable the protection. + (let ((inhibit-read-only t)) + ;(setq n (1+ n) + ; l (append l (list (list n 'input-filter string)))) + (if (marker-position guile-last-output-end) + (add-text-properties guile-last-output-end (1- (point)) + '(input-memory t rear-nonsticky t mouse-face highlight))))) + +(defun inda-reset-guile-last-output (string) + ;(setq n (1+ n) + ; l (append l (list (list n 'output-filter string)))) + (if (not scheme-ready-p) + (set-marker guile-last-output-end nil))) + +(define-key inferior-scheme-mode-map [mouse-2] 'inda-mouse-yank-at-click) +(define-key inferior-scheme-mode-map [S-mouse-2] 'inda-mouse-yank-at-click) + +;; Should rather be implemented with advice. +(defun inda-mouse-yank-at-click (click arg) + "Insert the last stretch of killed text at the position clicked on. +Also move point to one end of the text thus inserted (normally the end). +Prefix arguments are interpreted as with \\[yank]. +If `mouse-yank-at-point' is non-nil, insert at point +regardless of where you click." + (interactive "e\nP") + (if (get-char-property (posn-point (event-start click)) 'input-memory) + (if (memq 'shift (event-modifiers (car click))) + (inda-insert-input-memory click) + (inda-insert-input-memory-and-send click)) + ;; Give temporary modes such as isearch a chance to turn off. + (run-hooks 'mouse-leave-buffer-hook) + (or mouse-yank-at-point (mouse-set-point click)) + (setq this-command 'yank) + (yank arg))) + +(defun inda-insert-input-memory (event) + (interactive "e") + (let* ((pos (posn-point (event-start event))) + (beg (previous-single-property-change (1+ pos) 'mouse-face)) + (end (next-single-property-change pos 'mouse-face))) + (goto-char (point-max)) + (let ((input-start (point))) + (comint-kill-input) + (insert (buffer-substring beg end)) + (add-text-properties input-start (point) + '(mouse-face nil + rear-nonsticky nil + input-memory nil))))) + +(defun inda-insert-input-memory-and-send (event) + (interactive "e") + (inda-insert-input-memory event) + (guile-send-input)) + +(defun inda-boldify (string) + (put-text-property comint-last-input-start (point) 'face 'bold)) + +(defun inda-extend-read-only-overlay (string) + (if guile-input-sent-p + (let ((inhibit-read-only t)) + (move-overlay inda-read-only-overlay (point-min) (point))))) + +;;; Misc. utilities +;;; +(defun scheme-send-buffer () + "Send the current buffer to the inferior Scheme process." + (interactive) + (let (begin end) + (save-excursion + (goto-char (point-max)) + (setq end (point)) + (goto-char (point-min)) + (setq begin (point))) + (scheme-send-region begin end))) + +(defun indent-buffer () + "Indent entire buffer." + (interactive) + (save-excursion + (end-of-buffer) + (let ((end (point))) + (beginning-of-buffer) + (indent-region (point) end nil)))) + +(defun indent-defun () + "Indent lisp definition." + (interactive) + (save-excursion + (end-of-defun) + (let ((end (point))) + (beginning-of-defun) + (indent-region (point) end nil)))) + +(provide 'guile-init) +(run-hooks 'guile-init-load-hook) hunk ./site-lisp/guileint-1.5/guile.el 1 +;;; @(#) guile.el -- A GNU Emacs interface to Guile +;;; @(#) $Keywords: guile, comint, scheme-mode $ + +;; Copyright (C) 1995, 2002 Mikael Djurfeldt + +;; LCD Archive Entry: +;; guile|djurfeldt@nada.kth.se| +;; A GNU Emacs extension which | +;; $Date: 2002/10/20 09:13:55 $|$Revision: 1.45 $|~/misc/guile.el.Z| + +;; Author: Mikael Djurfeldt +;; Version: 1.5 + +;; This program is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by the Free +;; Software Foundation; either version 2 of the License, or (at your option) +;; any later version. +;; +;; This program 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 General Public License +;; for more details. +;; +;; You should have received a copy of the GNU General Public License along +;; with GNU Emacs. If you did not, write to the Free Software Foundation, +;; Inc., 675 Mass Ave., Cambridge, MA 02139, USA. + +;;; Commentary: +;; +;; Requirements: +;; +;; Usage: +;; +;; Bugs: +;; +;; +;;; ************************************************************************* +;;; * This is code is currently under development * +;;; * Mail any problems to djurfeldt@nada.kth.se * +;;; ************************************************************************* + +(require 'cl) +(require 'fcreate) + +(defvar guile-auto-attach nil) + +(defvar guile-load-hook nil + "*Hook run when file is loaded") + +;;(require 'cmuscheme) +(load "comint") ; `comint' and `cmuscheme' are already loaded. +(load "cmuscheme") ; We need to replace them. + +;; Faces are set in the cond expression below. + +(defvar guile-error-face nil + "Face used to highlight erroneous scheme forms.") + +(defvar guile-backtrace-mouse-face nil + "Face used when the mouse is over a backtrace frame.") + +(defvar guile-modified-face nil + "Face for modified top-level forms in scheme-mode buffers.") + +(defvar guile-broken-face nil + "Face for broken top-level forms in scheme-mode buffers.") + +;; These faces are used during debugging of the list parsing code. + +(defvar guile-unmodified-face-1 nil) +(defvar guile-unmodified-face-2 nil) +(defvar guile-modified-face-1 nil) +(defvar guile-modified-face-2 nil) +(defvar guile-broken-face-1 nil) +(defvar guile-broken-face-2 nil) + +;;; Customization +;;; + +(defvar guile-backtrace-in-source-window t + "*If non-nil, let backtrace windows appear in bottom of source window. +This only occurs if the erring expression can be located.") + +(defvar guile-show-runlight-in-scheme-mode nil + "*If non-nil, show process status also in attached scheme-mode buffers. +Otherwise the mode-line shows if the buffer is attached or not.") + +(defvar guile-default-enhanced-edit t + "If non-nil, automatically enter enhanced edit mode for scheme buffers.") + +(defvar guile-popup-restart-on-death t) + +(defvar guile-popup-restart-on-stop t) + +(defvar guile-insert-reason t) + +(defvar guile-kill-buffer-on-death nil) + +(defvar guile-process-timeout 500 + "Milliseconds") + +(defconst guile-backtrace-buffer-name "*Scheme Backtrace*") + +(defconst guile-error-buffer-name "*Scheme Error*") + +(defconst guile-backtrace-min-height 10) +(defconst guile-backtrace-max-height 30) +(defconst guile-backtrace-min-width 30) +(defconst guile-backtrace-max-width 90) + +(cond ((not window-system) + ;; Faces for text terminals + (setq guile-error-face 'modeline) + (setq guile-backtrace-mouse-face 'highlight) + (setq guile-modified-face nil) ; no special face + (setq guile-broken-face nil) + (setq guile-unmodified-face-1 nil) + (setq guile-unmodified-face-2 'modeline) + (setq guile-modified-face-1 'bold) + (setq guile-modified-face-2 guile-error-face) + (setq guile-broken-face-1 nil) + (setq guile-broken-face-2 nil)) + ((x-display-color-p) + ;; Faces for color screens + (setq guile-error-face (lookup-face-create 'black/red-bold)) + (setq guile-backtrace-mouse-face 'highlight) + (setq guile-modified-face nil) ; no special face + (setq guile-broken-face 'bold) + (setq guile-unmodified-face-1 (lookup-face-create 'black/lightblue)) + (setq guile-unmodified-face-2 'secondary-selection) + (setq guile-modified-face-1 'highlight) + (setq guile-modified-face-2 (lookup-face-create 'black/pink)) + (setq guile-broken-face-1 + (let ((face (make-face 'broken-form-1))) + (copy-face guile-modified-face-1 face) + (set-face-underline-p face t) + face)) + (setq guile-broken-face-2 + (let ((face (make-face 'broken-form-2))) + (copy-face guile-modified-face-2 face) + (set-face-underline-p face t) + face))) + (t + ;; Faces for monochrome screens + (setq guile-error-face (lookup-face-create 'white/black-bold)) + (setq guile-backtrace-mouse-face 'highlight) + (setq guile-modified-face nil) ; no special face + (setq guile-broken-face 'bold) + (setq guile-unmodified-face-1 nil) + (setq guile-unmodified-face-2 'modeline) + (setq guile-modified-face-1 'bold) + (setq guile-modified-face-2 guile-error-face) + (setq guile-broken-face-1 + (let ((face (make-face 'broken-form-1))) + (copy-face guile-modified-face-1 face) + (set-face-underline-p face t) + face)) + (setq guile-broken-face-2 + (let ((face (make-face 'broken-form-2))) + (copy-face guile-modified-face-2 face) + (set-face-underline-p face t) + face)))) + +(if (not (fboundp 'lisp-mode-auto-fill)) + (defun lisp-mode-auto-fill () + (if (> (current-column) (current-fill-column)) + (if (save-excursion + (nth 4 (parse-partial-sexp (save-excursion + (beginning-of-defun) + (point)) + (point)))) + (do-auto-fill) + (let ((comment-start nil) (comment-start-skip nil)) + (do-auto-fill)))))) + +(defconst guile-symclash-obarray-size 521) + +(defconst guile-big-integer 33333333) + +;;; Mode initializers +;;; + +(defvar guile-inferior-scheme-frame nil) + +;; Inferior Scheme Mode +;; +(defun guile-inferior-initialize () + ;; Buffer local variables + (make-local-variable 'guile-eval-result) + (make-local-variable 'guile-eval-output) + (make-local-variable 'guile-last-output-end) + (make-local-variable 'guile-last-prompt-end) + (make-local-variable 'guile-define-name-marker) + (make-local-variable 'guile-unallowed-output) + (make-local-variable 'guile-define-startcol) + (make-local-variable 'guile-define-filler) + (make-local-variable 'guile-define-fillcol) + (set-process-sentinel (scheme-proc) (function guile-sentinel)) + (setq comint-dispatch-alist guile-dispatch-alist) + (add-hook 'comint-input-filter-functions + (function guile-sync-on-input) nil 'local) + (add-hook 'comint-unallowed-output-filter-functions + (function guile-remember-unallowed-output) nil 'local) + (setq comint-dynamic-complete-functions '(guile-complete-symbol)) + (make-local-hook 'scheme-enter-input-wait-hook) + ;; Some initializations + (setq scheme-ready-p nil) + (setq scheme-load-p nil) + (setq guile-no-stack-p nil) + (setq guile-no-source-p nil) + (setq guile-last-output-end (make-marker)) + (setq guile-last-prompt-end (make-marker)) + (setq guile-input-sent-p t) + (setq guile-define-name-marker (make-marker)) + (setq guile-error-p nil) + (setq guile-sexp-overlay nil) + (setq guile-frame-overlay nil) + (let ((enhanced (guile-get-enhanced-buffers))) + (and scheme-buffer (guile-detach-all)) + (for-each (function guile-normal-edit) enhanced) + (guile-kill-overlays) + (for-each (function (lambda (buffer) + (save-excursion + (set-buffer buffer) + (guile-enhanced-edit + buffer + (not scheme-buffer-modified-p))))) + enhanced)) + (setq guile-synchronizedp t) + (setq comint-allow-output-p t) + (setq guile-unallowed-output nil) + ) + +(defvar default-handle-switch-frame-binding + (lookup-key global-map [switch-frame])) +(define-key global-map [switch-frame] 'guile-handle-switch-frame) + +(defun guile-handle-switch-frame (event) + (interactive "e") + (let ((frame (nth 1 event))) + (if (eq frame guile-inferior-scheme-frame) + (guile-sync-with-scheme)) + (funcall default-handle-switch-frame-binding frame))) + +(defun guile-sync-on-input (string) + (if scheme-load-p + (progn + nil)) + (setq guile-error-p nil) ;; What is this??? *fixme* + (guile-sync-with-scheme) + (if guile-error-p + (progn + ;; The read-only-overlay extends during transfer of error and + ;; backtrace information. Check why! *fixme* + (let ((inhibit-read-only t)) + (comint-kill-input)) + ;; By generating an error we interrupt the execution + ;; of the comint-input-filter-functions hook. + (error "Bad expression! Please correct.")))) + +(defvar guile-unallowed-output nil) + +(defun guile-remember-unallowed-output (string) + (if guile-unallowed-output + (setq guile-unallowed-output + (concat guile-unallowed-output string)))) + +(add-hook 'inferior-scheme-mode-hook (function guile-inferior-initialize)) + +;; Scheme Mode +;; +(defvar scheme-buffer-overlays () + "The overlays containing top-level sexps when in enhanced edit mode. +A nil value indicates that the buffer is not in enhanced edit mode.") + +(defvar scheme-buffer-last-overlay nil + "When in enhanced edit mode, this variable contains the lowermost +overlay.") + +(defvar scheme-buffer-modified-p nil + "Non-nil if any overlay has been modified since last synchronization.") + +(defvar scheme-buffer-overlays-modified-p nil) + +(defvar scheme-associated-process-buffer nil + "The buffer of the scheme process to which this buffer is associated. +A value of nil means that this buffer is detached.") + +(defvar scheme-overlay-repair-function nil) + +(make-variable-buffer-local 'scheme-overlay-repair-function) + +(defvar scheme-overlay-repair-idle-timer nil) + +(defun guile-scheme-mode-initialize () + "Initialize a scheme mode buffer." + (make-local-variable 'scheme-buffer-overlays) + (make-local-variable 'scheme-buffer-modified-p) + (make-local-variable 'scheme-buffer-last-overlay) + (make-local-variable 'scheme-buffer-overlays-modified-p) + (make-local-variable 'scheme-associated-process-buffer) + (make-local-variable 'guile-last-broken) + (make-local-variable 'guile-repair-limit) + (make-local-hook 'first-change-hook) + (add-hook 'first-change-hook (function guile-scheme-buffer-modified) nil t) + (make-local-hook 'kill-buffer-hook) + (add-hook 'kill-buffer-hook (function guile-scheme-mode-cleanup) nil t) + (if guile-default-enhanced-edit + (guile-enhanced-edit (current-buffer) + ;; If buffer not modified, take a chance... + (and (not scheme-buffer-modified-p) + (not (buffer-modified-p (current-buffer)))) + )) + ) + +(add-hook 'scheme-mode-hook (function guile-scheme-mode-initialize)) + +(defun guile-scheme-buffer-modified () + (setq scheme-buffer-modified-p t)) + +(defun guile-scheme-mode-cleanup () + (if (guile-attachedp (current-buffer)) + (progn + (guile-sync-buffer (current-buffer)) + (guile-detach-buffer (current-buffer)))) + (if (guile-enhancedp (current-buffer)) + (guile-normal-edit (current-buffer)))) + +;;; User interface support +;;; + +(defun guile-clear-transcript () + "Delete all text before the last prompt in the scheme process buffer." + (interactive) + (if (or (not (buffer-name)) + (not (string= (buffer-name) scheme-buffer))) + (error "This command must be issued in the scheme process buffer!")) + (save-excursion + (goto-char (or (marker-position guile-last-prompt-end) + (point-max))) + (if (re-search-backward comint-prompt-regexp nil t) + (goto-char (match-beginning 0)) + (beginning-of-line)) + (let ((inhibit-read-only t)) + (delete-region (point-min) (point))))) + +(defun guile-switch-to-scheme () + "Switch to the scheme process buffer and places cursor at the end. +Also update the scheme process with all changes made in attached buffers." + (interactive) + (guile-sync-with-scheme) + ;(if (not guile-error-p) + ; (switch-to-scheme t)) + (switch-to-scheme t)) + +;;; Process control +;;; +;(defvar scheme-running-p nil +; "This variable, if nil, indicates that the process is waiting for input.") + +(defvar scheme-ready-p nil + "If non-nil, the process is waiting for input at the top-level repl.") + +(defvar scheme-load-p nil) + +(defvar guile-no-stack-p nil) + +(defvar guile-no-source-p nil) + +(defun guile-inferior-dialog (contents) + (let ((window (display-buffer "*scheme*"))) + (x-popup-dialog window contents))) + +(defun guile-sentinel (process reason) + (let ((status (process-status process))) + (if guile-insert-reason + (let ((old-buffer (current-buffer))) + (unwind-protect + (progn + (set-buffer (process-buffer process)) + (goto-char (point-max)) + (insert reason) + (goto-char (point-max)) + (sit-for 0)) + (set-buffer old-buffer)))) + (cond ((eq status 'run) + (scheme-set-runlight scheme-last-runlight)) + ((eq status 'stop) + (scheme-set-runlight 'stopped) + (if guile-popup-restart-on-stop + (if (guile-inferior-dialog '("The scheme process has been stopped. +Do you want to restart it?" ("Yes" . t) nil ("No" . nil))) + (continue-process process)))) + (t + (guile-inferior-death-cleanup) + (if guile-popup-restart-on-death + (if (guile-inferior-dialog '("The scheme process has died. +Do you want to restart it?" ("Yes" . t) nil ("No" . nil))) + (run-scheme scheme-program-name) + (or guile-kill-buffer-on-death + (kill-buffer "*scheme*"))) + (or guile-kill-buffer-on-death + (kill-buffer "*scheme*"))))))) + +(defun guile-inferior-death-cleanup () + (scheme-set-runlight nil) + (setq scheme-ready-p nil) + (setq scheme-virtual-file-list nil) + (guile-detach-all)) + +;; It would be too late to set this variable in the inferior-scheme-mode-hook: +;;(setq comint-output-filter-function (function comint-dispatch-output-filter)) +;; *fixme* This should rather be done with advice. + +(defun run-scheme (cmd) + "Run an inferior Scheme process, input and output via buffer *scheme*. +If there is a process already running in *scheme*, just switch to that buffer. +With argument, allows you to edit the command line (default is value +of scheme-program-name). Runs the hooks from inferior-scheme-mode-hook +\(after the comint-mode-hook is run). +\(Type \\[describe-mode] in the process buffer for a list of commands.)" + + (interactive (list (if current-prefix-arg + (read-string "Run Scheme: " scheme-program-name) + scheme-program-name))) + (if (not (comint-check-proc "*scheme*")) + (let ((cmdlist (scheme-args-to-list cmd)) + (comint-output-filter-function + (function comint-dispatch-output-filter))) + (set-buffer (apply 'make-comint "scheme" (car cmdlist) + nil (cdr cmdlist))) + (inferior-scheme-mode))) + (setq scheme-program-name cmd) + (setq scheme-buffer "*scheme*") + (pop-to-buffer "*scheme*") + ;; *fixme* Ugly to specialize `run-scheme' in this way... + (setq guile-inferior-scheme-frame (selected-frame))) + +(defun guile-restart-scheme () + (interactive) + (let ((old-buffer (current-buffer))) + (unwind-protect + (progn + (set-buffer scheme-buffer) + (let ((attached-buffers inferior-scheme-associated-buffers)) + (guile-shutdown) + (let ((inhibit-read-only t)) + (erase-buffer)) + (setq comint-allow-output-p t) + (run-scheme scheme-program-name) + ;(sit-for 0 200) + (for-each (function (lambda (buffer) + (if (buffer-name buffer) + (guile-attach-buffer buffer)))) + (reverse attached-buffers)))) + (set-buffer old-buffer)))) + +(defun guile-shutdown () + (interactive) + (let ((guile-popup-restart-on-death nil) + (old-buffer (current-buffer))) + (unwind-protect + (progn + (set-buffer scheme-buffer) + (setq comint-allow-output-p nil) ; Hide output + (setq guile-unallowed-output nil) + (if scheme-ready-p + (let ((inhibit-read-only t)) + (comint-kill-input) + (comint-send-string (scheme-proc) "(quit)\n") + (let ((countdown 5)) + (while (and scheme-ready-p (> countdown 0)) + (sit-for 0 300) + (setq countdown (1- countdown)))))) + (sit-for 0 100) + (if (comint-check-proc "*scheme*") + (progn + (kill-process (scheme-proc)) + (while (comint-check-proc "*scheme*") + (sit-for 0 300)))) + (sit-for 0 100)) + (set-buffer old-buffer)))) + +(defun guile-exit-scheme () + "Stop the running scheme process and kill the corresponding window" + (interactive) + (guile-shutdown) + (if (not (comint-check-proc "*scheme*")) + (kill-buffer "*scheme*"))) + +;;; Basic process protocol + +(setq guile-dispatch-alist + '((?f scheme-exit-input-wait scheme:simple-action) + (?l scheme-load-acknowledge scheme:simple-action) + (?r scheme-enter-read scheme:simple-action) + (?s scheme-enter-input-wait scheme:simple-action) + (?B guile-receive-backtrace scheme:buffer-action) + (?F guile-receive-error scheme:buffer-action) + (?x guile-receive-result scheme:string-action) + (?S guile-no-stack scheme:simple-action) + (?R guile-no-source scheme:simple-action) + )) + +(defun scheme:simple-action (action) + (setq comint-dispatch-state 'idle) + (funcall action)) + +(defun scheme:string-action (action) + (setq comint-string-receiver action) + (setq comint-string-accumulator "") + (setq comint-dispatch-state 'reading-string)) + +(defun scheme:buffer-action (action) + (setq comint-buffer-receiver action) + (setq comint-receiving-buffer (generate-new-buffer "*receiving-buffer*")) + (setq comint-dispatch-state 'reading-to-buffer)) + +;;; Guile protocol + +(defun guile-no-stack () + (setq guile-no-stack-p t)) + +(defun guile-no-source () + (setq guile-no-source-p t)) + +(defvar guile-eval-result nil) +(defvar guile-eval-output nil) + +(defun guile-receive-result (string) + (setq comint-allow-output-p nil) + (setq guile-eval-result string) + (setq guile-eval-output guile-unallowed-output) + (setq guile-unallowed-output nil)) + +(defun guile-eval (sexp &optional stringp) + (let ((process (scheme-proc)) ;*fixme* + (comint-input-filter-functions '()) + (comint-output-filter-functions '())) + (if (not scheme-ready-p) + (error "Scheme process not ready to receive commands.")) + (setq guile-eval-result nil) + (comint-send-string process + (format "(%%%%emacs-eval-request '%S)\n" sexp)) + (while (not guile-eval-result) + (accept-process-output process)) + (while (not scheme-ready-p) + (accept-process-output process)) + (if stringp + guile-eval-result + (car (read-from-string guile-eval-result))))) + +(defun scheme-set-runlight (runlight) + (setq inferior-scheme-mode-line-process + (or runlight "no process")) + (setq scheme-last-runlight runlight) + (if guile-show-runlight-in-scheme-mode + (let ((old-buffer (current-buffer)) + (buffers inferior-scheme-associated-buffers)) + (unwind-protect + (while buffers + (set-buffer (car buffers)) + (setq scheme-mode-line-process runlight) + (setq buffers (cdr buffers))) + (set-buffer old-buffer)))) + (force-mode-line-update t)) + +(defconst scheme-runlight:running "eval" + "The character displayed when the Scheme process is running.") + +(defconst scheme-runlight:input "ready" + "The character displayed when the Scheme process is waiting for input.") + +(defconst scheme-runlight:read "input" + "The character displayed when the Scheme process is waiting for input.") + +(defconst scheme-runlight:load "loading" + "The character displayed when the Scheme process is loading forms.") + +(defvar guile-last-output-end) + +(setq count 0) +(defun scheme-enter-input-wait () + (scheme-set-runlight scheme-runlight:input) + (setq scheme-running-p nil) + (setq scheme-ready-p t) + (setq count (1+ count)) + ;(insert-before-markers (format "#%d\n" count)) + ;(setq n (1+ n) + ; l (append l (list (list n 'enter-input-wait)))) + (if comint-allow-output-p + (progn + (set-marker guile-last-output-end (point)) + (if (and guile-input-sent-p + ;; This code can be invoked multiple times + (or (not (marker-position guile-last-prompt-end)) + (/= (marker-position guile-last-prompt-end) + (point)))) + (progn + (setq guile-input-sent-p nil) + (set-marker guile-last-prompt-end (point)))))) + (setq comint-allow-output-p t) + (run-hooks 'scheme-enter-input-wait-hook)) + +(defun guile-on-error () + (setq guile-input-sent-p t) ;*fixme* + (if comint-allow-output-p + (progn + (goto-char (point-max)) + (if (not (zerop (current-column))) + (insert "\n")) + (set-marker (process-mark (get-buffer-process scheme-buffer)) + (point))))) + +(defun scheme-exit-input-wait () + (scheme-set-runlight scheme-runlight:running) + (setq scheme-ready-p nil) + (setq scheme-running-p t)) + +(defun scheme-enter-read () + (scheme-set-runlight scheme-runlight:read) + (setq scheme-ready-p nil) + (setq scheme-running-p nil)) + +(defun scheme-enter-load () + (scheme-set-runlight scheme-runlight:load) + (setq scheme-ready-p nil) + (setq scheme-load-p t)) + +(defun scheme-load-acknowledge () + (setq scheme-load-p nil)) + +;;; Error reporting and backtrace +;;; +(defvar guile-error-p nil) + +(defvar guile-last-displayed-position nil) + +(defvar guile-positional-reliability nil) + +(defvar guile-last-erring-overlay nil) + +(defvar guile-sexp-overlay nil) + +(defvar guile-frame-overlay nil) + +;(defconst guile-position-regexp +; " at line \\([0-9]+\\), column \\([0-9]+\\) in file \\(.+\\):$") +(defconst guile-position-regexp + "^\\(.+\\):\\([0-9]+\\):\\([0-9]+\\): ") + +(defconst guile-position-regexp-line 2) +(defconst guile-position-regexp-column 3) +(defconst guile-position-regexp-filename 1) + +(defvar guile-error-width 0) +(defvar guile-backtrace-length nil) +(defvar guile-backtrace-width 0) + +(defvar guile-error-map nil) +(if guile-error-map + nil + (setq guile-error-map ;(copy-keymap global-map) copies menus too... + (cons 'keymap (copy-sequence (nth 1 global-map)))) + (suppress-keymap guile-error-map) + (define-key guile-error-map "\e" 'guile-exit-debug) + (define-key guile-error-map "e" 'guile-frame-eval) + (define-key guile-error-map "q" 'guile-exit-debug) + ;; The following line is included since `local-map' doesn't seem to work. + (define-key guile-error-map [mouse-2] 'guile-select-stackframe) + (define-key guile-error-map [S-mouse-2] 'guile-frame-eval-at-click) + ) + +(defvar guile-stack-frame-map nil) +(if guile-stack-frame-map + nil + (setq guile-stack-frame-map (copy-list guile-error-map)) + (fset 'guile-stack-frame-map guile-stack-frame-map) ;*fixme* + (define-key guile-stack-frame-map [mouse-2] 'guile-select-stackframe) + ) + +(setplist 'guile-backtrace-button + (list 'mouse-face guile-backtrace-mouse-face + 'local-map 'guile-stack-frame-map)) + +(defun guile-exit-debug () + (interactive) + (if (eq (selected-frame) guile-error-frame) + (iconify-frame) + (if guile-sexp-overlay + (delete-overlay guile-sexp-overlay)) + (delete-other-windows (frame-first-window))) + (guile-unselect-stackframe)) + +(setq guile-backtrace-received-p nil) ;*fixme* + +(defun guile-receive-backtrace (buffer) + (let ((backtrace (get-buffer-create guile-backtrace-buffer-name))) + (save-excursion + (set-buffer backtrace) + (toggle-read-only 0) + (erase-buffer) + (insert-buffer-substring buffer) + (kill-buffer buffer) + (use-local-map guile-error-map) + (toggle-read-only 1) + (setq truncate-lines t) + (setq guile-backtrace-received-p t)))) ;*fixme* + +(defun guile-prep-backtrace () + (guile-unselect-stackframe) + (let ((buffer (get-buffer-create guile-backtrace-buffer-name))) + (and guile-got-backtrace-p ;*fixme* + (save-excursion + (set-buffer buffer) + (set-syntax-table scheme-mode-syntax-table) + (toggle-read-only 0) + (goto-char (point-max)) + (delete-backward-char 1) + (goto-char (point-min)) + ;; Parse + (save-match-data + (if (not (looking-at "\\(.\\|\n\\)*Backtrace:\n")) + nil + (replace-match "") + (let ((beg (point)) + (width 0) + (len 0)) + (while (not (eobp)) + (forward-line 1) + (let ((o (make-overlay beg (point)))) ;(1- (point)) + (overlay-put o 'category 'guile-backtrace-button) + (overlay-put o 'frame-number-pos beg)) + (setq width (- (point) beg 1)) + (if (> width guile-backtrace-width) + (setq guile-backtrace-width width)) + (setq beg (point)) + (setq len (1+ len))) + (setq guile-backtrace-length len)))) + (toggle-read-only 1))) + buffer)) + +(defvar guile-selected-frame nil) + +(defun guile-select-stackframe (click) + (interactive "e") + (setq guile-no-stack-p nil) + (setq guile-no-source-p nil) + (let* ((frame (save-excursion + (mouse-set-point click) + (goto-char (get-char-property (point) 'frame-number-pos)) + (guile-place-frame-overlay) + (let ((start (point))) + (skip-chars-forward "0-9") + (string-to-number (buffer-substring start (point)))))) + (oldpos (save-excursion + (set-buffer scheme-buffer) + (guile-eval `(%%emacs-select-frame ,frame)))) + (pos (and oldpos (list (nth 0 oldpos) + (1+ (nth 1 oldpos)) ;Increment line number + (nth 2 oldpos))))) + (setq guile-selected-frame frame) + (cond (pos (if guile-source-window ;This is just insane *fixme* + (apply 'guile-display-scheme-sexp + (append pos (list guile-source-window t))) + (guile-display-error (get-buffer guile-error-buffer-name) + (get-buffer guile-backtrace-buffer-name) + pos))) + (guile-no-stack-p (message "No stack.")) + (guile-no-source-p (message "No source."))))) + +(defun guile-unselect-stackframe () + (guile-turn-off-frame-overlay) + (setq guile-selected-frame nil)) + +(defun guile-frame-eval (string) + (interactive "sEval: ") + (if (not guile-selected-frame) + (message "No frame selected.") + (setq guile-no-stack-p nil) + (setq guile-no-source-p nil) + (let ((res (save-excursion + (set-buffer scheme-buffer) + (guile-eval `(%%emacs-frame-eval ,guile-selected-frame + ,string))))) + (cond (guile-no-stack-p (message "No stack.")) + (guile-no-source-p (message "No source.")) + ((eq (car res) 'result) (message "%s = %s" string (cadr res))) + (t (message "%s" (cadr res))))))) + +(defun guile-frame-eval-at-click (click) + (interactive "e") + (save-excursion + (mouse-set-point click) + (forward-sexp) + (let ((end (point))) + (backward-sexp) + (guile-frame-eval (buffer-substring (point) end))))) + +(defun guile-receive-error (buffer) + (guile-on-error) + (setq guile-got-backtrace-p guile-backtrace-received-p) + (setq guile-backtrace-received-p nil) ;*fixme* + (setq guile-error-p t) + (let ((errbuf (get-buffer-create guile-error-buffer-name))) + (save-excursion + (set-buffer errbuf) + (toggle-read-only 0) + (erase-buffer) + (insert-buffer-substring buffer) + (kill-buffer buffer) + (use-local-map guile-error-map) + (toggle-read-only 1) + (setq guile-error-width 0) + (goto-char (point-min)) + (let ((beg (point)) + (width 0)) + (while (not (eobp)) + (forward-line 1) + (setq width (- (point) beg 1)) + (if (> width guile-error-width) + (setq guile-error-width width)) + (setq beg (point)))) + (setq guile-backtrace-width guile-error-width) + (guile-display-error errbuf (guile-prep-backtrace))))) + +(defvar guile-source-window nil) + +(defun guile-display-error (errbuf backbuf &optional pos) + (set-buffer errbuf) + (setq guile-source-window nil) + (let* ((errbuf-len (progn + (goto-char (point-max)) + (1- (guile-current-line)))) + (selected-window (selected-window)) + (mini-window nil) + (window + (if pos + (apply 'guile-display-scheme-sexp pos) + (and (progn + (goto-char (point-min)) + (re-search-forward guile-position-regexp nil t)) + (save-match-data + (guile-display-scheme-sexp + (car (read-from-string + (concat "\"" + (match-string guile-position-regexp-filename) + "\""))) + (string-to-number (match-string guile-position-regexp-line)) + (1- (string-to-number (match-string guile-position-regexp-column)))))))) + (errbuf-lines + (min (+ errbuf-len + (* 2 (/ guile-error-width + (if window + (window-width window) + guile-backtrace-max-width)))) + ;;In case we get big error messages + (/ guile-backtrace-max-height 2))) + (total-height + (if guile-got-backtrace-p + (min (max (+ guile-backtrace-length errbuf-lines 2) + guile-backtrace-min-height) + guile-backtrace-max-height) + (+ errbuf-lines 1)))) + (if (and window guile-backtrace-in-source-window) + (progn + (set-buffer errbuf) ;*fixme* This is awkward... + (or pos + (let ((inhibit-read-only t)) + (replace-match "") + (re-search-forward guile-position-regexp nil t) + (replace-match ""))) + (setq guile-source-window window) ;*fixme* + (and (frame-live-p guile-error-frame) + (make-frame-invisible guile-error-frame)) + (let* ((window-min-height 2) + (size (max (- (window-height window) total-height) + (/ (window-height window) 2))) + (new-window (split-window window size))) + (set-buffer (window-buffer window)) + (goto-char guile-last-displayed-position) + (guile-safe-forward-sexp) + (recenter (/ size 2)) + (setq x errbuf-lines) + (guile-display-buffers errbuf (1+ errbuf-lines) backbuf new-window + pos))) + (setq guile-source-window nil) + (guile-display-buffers + errbuf (1+ errbuf-lines) backbuf + (setq mini-window + (guile-get-create-error-window + total-height + (+ (min (max guile-backtrace-width + guile-backtrace-min-width) + guile-backtrace-max-width) + 2))) + pos)) + (cond ((window-live-p selected-window) + (select-window selected-window)) + ((window-live-p window) + (select-window window)) + ((window-live-p mini-window) + (select-window mini-window))) + ;; Warn if unreliable position + (if (and window (not guile-positional-reliability)) + (message "Warning: Couldn't reliably locate erring expression.")) + )) + +(defun guile-display-buffers (buffer1 split buffer2 window no-ding) + "Display BUFFER1 and BUFFER2 in WINDOW and raise the containing frame. +Display BUFFER1 and BUFFER2 in two windows obtained by splitting WINDOW +and ring the bell. Make sure that the whole contents of BUFFER1 and the +lower part of BUFFER2 will be visible. Also delete all other windows +displaying the buffers." + ;; Delete other windows displaying the buffers + (or (not window-system) (delete-windows-on buffer1)) ; *fixme* + (delete-windows-on buffer2) + ;; Split the window + (let ((lower-window + (and guile-got-backtrace-p + (let ((window-min-height 2) ;; Parameter to split-window + ) + (split-window window split))))) + ;; Contents + (set-window-buffer window buffer1) + (and guile-got-backtrace-p + (set-window-buffer lower-window buffer2)) + ;; Look + (set-window-start window 1) + (if guile-got-backtrace-p + (progn + (let ((pos (save-excursion + (set-buffer buffer2) + (goto-char (point-max)) + (forward-line -1) + (point)))) + (set-window-point lower-window pos)) + (select-window lower-window) + (recenter -1))) + ;; Raise frame + (make-frame-visible (window-frame window)) + (raise-frame (window-frame window)) + ;; Beep + (or no-ding (ding)) + )) + +(defvar guile-error-frame nil) + +(defun guile-get-create-error-window (height width) + (if window-system + (progn + (if (frame-live-p guile-error-frame) + (set-frame-size guile-error-frame width height) + (setq guile-error-frame (make-frame (list (cons 'height height) + (cons 'width width) + '(minibuffer . nil) + '(menu-bar-lines . 0))))) + (let ((window (frame-first-window guile-error-frame))) + (delete-other-windows window) + window)) + (let ((window (get-buffer-window (pop-to-buffer guile-error-buffer-name)))) + (sit-for 0) ; necessary because of an Emacs bug + window))) + +(defun guile-display-scheme-sexp (filename line column &optional swindow no-error-p) + (let ((finfo (scheme-virtual-file-list-find filename))) + (if finfo + (guile-display-sexp finfo line column swindow no-error-p) + (if (stringp filename) + (let ((buffer (guile-get-file-buffer filename))) + (if buffer + (if (and (guile-attachedp buffer) + (not guile-known-by-scheme)) + (progn + ;(ding) ; We shouldn't generate errors inside a filter. + ;(message "Internal data structures corrupt: guile-display-scheme-sexp") + (error "Internal data structures corrupt: guile-display-scheme-sexp")) + (if (and (not scheme-buffer-modified-p) + (not (buffer-modified-p buffer))) + ;; Take a chance and let's hope the file looks + ;; like it did when scheme saw it... + (progn + (if guile-auto-attach + (guile-attach-buffer buffer t) + ;*fixme* + (guile-dont-attach-buffer buffer t)) + (guile-display-scheme-sexp + (guile-buffer-file-name buffer) line column swindow no-error-p)) + nil ; Can't trust this one... + )) + (if (guile-file-readable-p filename) + (let ((guile-known-by-scheme t)) + (let ((buffer (guile-find-file-noselect filename))) + (if guile-auto-attach + (guile-attach-buffer buffer t) + ;*fixme* + (guile-dont-attach-buffer buffer t)) + (guile-display-scheme-sexp + (guile-buffer-file-name buffer) + line column swindow no-error-p))) + (ding) + (message "Couldn't find the erring file.") + nil))))))) + +(defun guile-file-readable-p (filename) + (save-excursion + (set-buffer scheme-buffer) + (file-readable-p filename))) + +(defun guile-find-file-noselect (filename) + (save-excursion + (set-buffer scheme-buffer) + (find-file-noselect filename))) + +(defun guile-display-sexp (finfo line column &optional swindow no-error-p) + ;; Returns the window containing the displayed sexp + (let ((overlay-list (cdr finfo)) + (overlay nil)) + ;; Select an overlay candidate + (while overlay-list + (if (not (overlay-get (car overlay-list) 'original-line)) + (setq overlay-list (cdr overlay-list)) + (if (>= line (overlay-get (car overlay-list) 'original-line)) + (progn + (setq overlay (car overlay-list)) + (setq overlay-list nil)) + (setq overlay-list (cdr overlay-list))))) + (let ((buffer (and overlay (overlay-buffer overlay)))) + (if buffer + (progn + (set-buffer buffer) + (guile-goto-position line column overlay) + (if (< (point) (overlay-end overlay)) + (progn + (setq guile-positional-reliability + (not (overlay-get overlay 'modifiedp))) + (if (not (eq (char-syntax (following-char)) ?\()) + (progn + (setq guile-positional-reliability nil) + (goto-char (overlay-start overlay)))) + (setq guile-last-erring-overlay overlay) + (guile-display-sexp-at-point swindow no-error-p)))))))) + +(defun guile-display-sexp-at-point (&optional swindow no-error-p) + "Move sexp overlay to sexp at point and display window. +Returns the displayed window." + (let ((start (point)) + (end nil)) + (save-excursion + (setq end + (if (guile-safe-forward-sexp) + (point) + (goto-char (1+ start)) + (if (re-search-forward "^\\((\\|$\\)" nil t) + (1- (match-beginning 0)) + (point-max))))) + (if (overlayp guile-sexp-overlay) + (move-overlay guile-sexp-overlay start end (current-buffer)) + (setq guile-sexp-overlay (make-overlay start end)) + (overlay-put guile-sexp-overlay 'category 'guile-error-sexp)) + (if (window-live-p swindow) + (set-window-buffer swindow (current-buffer))) + (guile-display-position start nil swindow no-error-p))) + +(setplist 'guile-error-sexp + (list 'face guile-error-face + 'evaporate t + 'modification-hooks '(guile-turn-off-sexp-overlay) + 'insert-behind-hooks '(guile-turn-off-sexp-overlay))) + +(setplist 'guile-stack-frame + (list 'face guile-error-face + 'mouse-face guile-error-face + 'evaporate t + 'modification-hooks '(guile-turn-off-frame-overlay) + 'insert-behind-hooks '(guile-turn-off-frame-overlay))) + +(defun guile-place-frame-overlay () + (let ((end (save-excursion (forward-line) (point)))) + (if (and guile-frame-overlay (overlayp guile-frame-overlay)) + (move-overlay guile-frame-overlay (point) end) + (setq guile-frame-overlay (make-overlay (point) end))) + (overlay-put guile-frame-overlay 'category 'guile-stack-frame))) + +(defun guile-turn-off-sexp-overlay (&rest args) + (cond (guile-sexp-overlay (delete-overlay guile-sexp-overlay)) + ;; For stability. + ((overlayp (car args)) (delete-overlay (car args))))) + +(defun guile-turn-off-frame-overlay (&rest args) + (cond (guile-frame-overlay (delete-overlay guile-frame-overlay)) + ;; For stability. + ((overlayp (car args)) (delete-overlay (car args))))) + +(defun guile-display-position (pos &optional buffer swindow no-delete-p) + "Display position POS in BUFFER. +If BUFFER is omitted, the current buffer is used. +Returns the displaying window." + (let ((buffer (or buffer (current-buffer)))) + (set-buffer buffer) + (let ((window (or (and (window-live-p swindow) swindow) + (get-buffer-window buffer t) + (if (frame-live-p guile-error-frame) + (delete-frame guile-error-frame)) + (display-buffer buffer)))) + (or no-delete-p + (delete-other-windows window)) + (select-window window) + (goto-char pos) + (setq guile-last-displayed-position pos) + window))) + +(defun guile-goto-position (line column overlay) + (goto-char (overlay-start overlay)) + (forward-line (- line (overlay-get overlay 'original-line))) + (move-to-column column)) + + +;;; Scheme process associated buffers +;;; + +;; This function must be fixed to handle rel/absol filenames +(defun guile-get-file-buffer (filename) + (get-file-buffer filename)) + +(defun guile-attachedp (&optional buffer) + (if buffer + (save-excursion + (set-buffer buffer) + scheme-associated-process-buffer) + scheme-associated-process-buffer)) + +(defun guile-attach-buffer (buffer &optional known-by-scheme) + "Put the buffer in enhanced editing mode and attach it to the scheme +process: load it into scheme, and make sure to send any changes to it +hereafter to scheme at synchronization points." + (interactive (list (current-buffer))) + (if (memq buffer inferior-scheme-associated-buffers) + (error "Scheme buffer already attached!")) + (if (not (guile-enhancedp buffer)) + (guile-enhanced-edit buffer known-by-scheme)) + (save-excursion + (set-buffer scheme-buffer) + (setq inferior-scheme-associated-buffers + (cons buffer + inferior-scheme-associated-buffers)) + (set-buffer buffer) + (setq scheme-associated-process-buffer scheme-buffer) + (if (not guile-show-runlight-in-scheme-mode) + (setq scheme-mode-line-process "attached")) + ;; Now link it to the scheme process + (if (and (guile-buffer-file-name) + (not (guile-virtually-linked-p (guile-buffer-file-name)))) + (guile-virtual-link (guile-buffer-file-name) scheme-buffer-overlays)) + ;; And sync. + (if (not known-by-scheme) + (progn + (for-each (function (lambda (overlay) + (overlay-put overlay 'modifiedp t))) + scheme-buffer-overlays) + (setq scheme-buffer-modified-p t) + (setq guile-synchronizedp nil) + (guile-sync-with-scheme)))) + ;; Rebuild menus... + (force-mode-line-update)) + +;;*fixme* +(defun guile-dont-attach-buffer (buffer &optional known-by-scheme) + "Put the buffer in enhanced editing mode and attach it to the scheme +process: load it into scheme, and make sure to send any changes to it +hereafter to scheme at synchronization points." + (interactive (list (current-buffer))) + (if (memq buffer inferior-scheme-associated-buffers) + (error "Scheme buffer already attached!")) + (if (not (guile-enhancedp buffer)) + (guile-enhanced-edit buffer known-by-scheme)) + (save-excursion +; (set-buffer scheme-buffer) +; (setq inferior-scheme-associated-buffers +; (cons buffer +; inferior-scheme-associated-buffers)) + (set-buffer buffer) +; (setq scheme-associated-process-buffer scheme-buffer) == attach +; (if (not guile-show-runlight-in-scheme-mode) +; (setq scheme-mode-line-process "attached")) + ;; Now link it to the scheme process + (if (guile-buffer-file-name) + (guile-virtual-link (guile-buffer-file-name) scheme-buffer-overlays)) + ;; And sync. + (if (not known-by-scheme) + (progn + (for-each (function (lambda (overlay) + (overlay-put overlay 'modifiedp t))) + scheme-buffer-overlays) + (setq scheme-buffer-modified-p t) + (setq guile-synchronizedp nil) + ;(guile-sync-with-scheme) + ))) + ;; Rebuild menus... + (force-mode-line-update)) + +(defun guile-detach-buffer (buffer) + "Disconnect the buffer from the scheme process." + (interactive (list (current-buffer))) + (save-excursion + (set-buffer buffer) + ;; Unlink any virtual overlay files associated with the buffer... + ;(let ((overlays scheme-buffer-overlays)) + ; (while overlays + ; (if (guile-virtual-p (car overlays)) + ; (scheme-virtual-unlink (overlay-get (car overlays) 'id))) + ; (setq overlays (cdr overlays)))) + (setq scheme-associated-process-buffer nil) + (if (not guile-show-runlight-in-scheme-mode) + (setq scheme-mode-line-process nil)) + (set-buffer scheme-buffer) + (setq inferior-scheme-associated-buffers + (delq buffer + inferior-scheme-associated-buffers)) + ;(scheme-virtual-unlink (guile-buffer-file-name buffer)) + ) + (force-mode-line-update)) + +(defun guile-detach-all () + "Disconnect all buffers from the scheme process." + (interactive) + (save-excursion + (set-buffer scheme-buffer) + (while inferior-scheme-associated-buffers + ;; Is it alive? + (if (buffer-name (car inferior-scheme-associated-buffers)) + (save-excursion + (set-buffer (car inferior-scheme-associated-buffers)) + (setq scheme-associated-process-buffer nil) + (if (not guile-show-runlight-in-scheme-mode) + (setq scheme-mode-line-process nil)))) + (setq inferior-scheme-associated-buffers + (cdr inferior-scheme-associated-buffers))))) + +;;; Linkage of files to scheme space +;;; +(defvar scheme-virtual-file-list '()) + +(defun scheme-virtual-file-list-find (name) + (let ((name (file-truename name))) + (assoc name scheme-virtual-file-list))) + +(defun guile-buffer-file-name (&optional buffer) + (let ((name (buffer-file-name buffer))) + (and name + (file-truename name)))) + +(defvar guile-synchronizedp t) + +(defvar guile-last-virtual-id 0) + +(defun guile-synchronizedp () + guile-synchronizedp) + +;;*fixme* +(defun guile-alloc-virtual-id (overlay) + (let ((n (setq guile-last-virtual-id (1+ guile-last-virtual-id)))) + (let* ((buffer (overlay-buffer overlay)) + (name (or (guile-buffer-file-name buffer) + (buffer-name buffer)))) + (format "%s(%d)" name n)))) + +(defun guile-virtual-p (overlay) + (overlay-get overlay 'virtualp)) + +(defun guile-virtually-linked-p (name) + (scheme-virtual-file-list-find name)) + +(defun guile-virtual-link (name overlay-list) + (let ((finfo (scheme-virtual-file-list-find name))) + (if finfo + (progn + (guile-kill-overlays (cdr finfo)) + (setcdr finfo (copy-sequence overlay-list))) + (setq scheme-virtual-file-list + (cons (cons name + (copy-sequence overlay-list)) + scheme-virtual-file-list))))) + +(defun scheme-virtual-unlink (name) + (let ((finfo (scheme-virtual-file-list-find name))) + (if finfo + (setq scheme-virtual-file-list + (delq finfo scheme-virtual-file-list))))) + +(defun guile-load-file (filename) + "Load a Scheme file into the inferior Scheme process." + (interactive (comint-get-source "Load Scheme file: " scheme-prev-l/c-dir/file + scheme-source-modes t)) ; T because LOAD + ; needs an exact name + (if (not scheme-ready-p) + (error "Scheme not ready.")) + (comint-check-source filename) ; Check to see if buffer needs to be saved. + (setq scheme-prev-l/c-dir/file (cons (file-name-directory filename) + (file-name-nondirectory filename))) + (let ((old-buffer (current-buffer))) + (set-buffer scheme-buffer) + (setq comint-allow-output-p nil) + (setq guile-unallowed-output nil) + (set-buffer old-buffer)) + (scheme-set-runlight scheme-runlight:load) + (setq scheme-ready-p nil) + (comint-send-string (scheme-proc) (concat "(load \"" + filename + "\"\)\n")) + ;; Syncronize... + (while (not scheme-ready-p) + (accept-process-output (scheme-proc) 0 guile-process-timeout)) + ) + +(defun guile-reread-buffer (buffer) + "Make the scheme interpreter read the buffer contents again." + (interactive (list (current-buffer))) + (if (not scheme-ready-p) + (error "Scheme not ready.")) + (save-excursion + (set-buffer buffer) + (for-each (function (lambda (overlay) + (overlay-put overlay 'modifiedp t))) + scheme-buffer-overlays) + (setq scheme-buffer-modified-p t)) + (setq guile-synchronizedp nil) + (guile-sync-with-scheme)) + +(defun guile-get-associated-buffers () + (save-excursion + (set-buffer scheme-buffer) + inferior-scheme-associated-buffers)) + +(defvar guile-symclash-obarray (make-vector guile-symclash-obarray-size 0)) + +(defun guile-reset-symclash-obarray () + (mapatoms (function makunbound) guile-symclash-obarray)) + +(defvar guile-displayed-erring-buffers nil) +(defvar guile-quiet t) + +(defun guile-check-all () + (interactive) + (setq guile-quiet t) + (guile-check-all-1)) + +(defun guile-check-all-1 () + (guile-show-check-error + (catch 'erroneous-overlay + (guile-reset-symclash-obarray) + (if (not (and guile-last-displayed-erring-overlay + (eq (overlay-buffer guile-last-displayed-erring-overlay) + (current-buffer)))) + (progn + (setq guile-last-displayed-erring-overlay nil) + (setq guile-displayed-erring-buffers nil))) + (for-each (function (lambda (buffer) + (guile-check-buffer-1 buffer) + (setq guile-displayed-erring-buffers + (cons buffer + guile-displayed-erring-buffers)))) + (let ((ls (guile-get-enhanced-buffers)) + (rem guile-displayed-erring-buffers)) + (while rem + (setq ls (delq (car rem) ls)) + (setq rem (cdr rem))) + ls)) + nil))) + +(defun guile-check-buffer (buffer) + (interactive (list (current-buffer))) + (guile-show-check-error + (catch 'erroneous-overlay + (save-excursion + (guile-reset-symclash-obarray) + (guile-check-buffer-1 buffer) + ;(set-buffer old-buffer) + nil)))) + +(defun guile-show-check-error (oinfo) + (if (not oinfo) + (progn + (if guile-last-displayed-erring-overlay + (message "No more errors found among buffers in enhanced editing mode!") + (message "No errors found among buffers in enhanced editing mode!")) + (setq guile-last-displayed-erring-overlay nil) + (setq guile-displayed-erring-buffers nil) + t) + (setq guile-last-displayed-erring-overlay (car oinfo)) + (set-buffer (overlay-buffer (car oinfo))) + (goto-char (overlay-start (car oinfo))) + (if (not guile-quiet) + (ding)) + (guile-display-sexp-at-point) + (recenter) + (message "%s" (cdr oinfo)) + nil)) + +(defvar guile-last-displayed-erring-overlay nil) + +(defun guile-check-buffer-1 (buffer) + (set-buffer buffer) + (save-excursion + (for-each (function guile-check-overlay) + (let* ((ls (reverse scheme-buffer-overlays)) + (tail (memq guile-last-displayed-erring-overlay ls))) + (if tail + (cdr tail) + ls))))) + +(defconst guile-defexpr "(\\(define\\|defmacro\\)[^ \t\n()]*[ \t\n]+(*\\([^ \t\n()]+\\)") +(defconst guile-defexpr-name 2) + +(defun guile-check-overlay (overlay) + (if (overlay-get overlay 'brokenp) + (throw 'erroneous-overlay + (cons overlay "Bad expression.")) + (goto-char (overlay-start overlay)) + (if (looking-at guile-defexpr) + (let ((sym (intern (match-string guile-defexpr-name) + guile-symclash-obarray))) + (if (boundp sym) + (let* ((overlay1 (symbol-value sym)) + (buffer (overlay-buffer overlay1)) + (line (save-excursion + (set-buffer buffer) + (save-excursion + (goto-char (overlay-start overlay1)) + (guile-current-line))))) + (throw 'erroneous-overlay + (cons overlay + (format "Symbol \"%s\" already defined in %s, line %d." + sym + (file-name-nondirectory + (or (guile-buffer-file-name buffer) + (buffer-name buffer))) + line)))) + (set sym overlay)))))) + +(defun guile-sync-with-scheme () + (interactive) + (if (and (not guile-synchronizedp) + scheme-ready-p) + (progn + (setq guile-error-p nil) + (setq guile-last-erring-overlay nil) + (catch 'exit + (for-each (function guile-sync-buffer-1) + (guile-get-associated-buffers)) + (setq guile-synchronizedp t)) + (if guile-last-erring-overlay + (progn + (overlay-put guile-last-erring-overlay 'brokenp t) + (overlay-put guile-last-erring-overlay + 'face guile-broken-face) + (if guile-show-overlays-p + (save-excursion + (set-buffer (overlay-buffer guile-last-erring-overlay)) + (guile-show-overlays)))))))) + +(defun guile-sync-buffer (buffer) + (interactive (list (current-buffer))) + (catch 'exit + (guile-sync-buffer-1 buffer))) + +(defun guile-sync-buffer-1 (buffer) + (save-excursion + (set-buffer buffer) + (if scheme-buffer-modified-p + (progn + ;; Can we do it by loading the file again? + (if (and (not (buffer-modified-p buffer)) + (file-readable-p (guile-buffer-file-name)) + (not (let ((overlays scheme-buffer-overlays)) + (while (and overlays + (not (overlay-get (car overlays) 'brokenp))) + (goto-char (overlay-start (car overlays))) + (overlay-put (car overlays) 'original-line + (guile-current-line)) ; non-optimal *fixme* + (setq overlays (cdr overlays))) + overlays))) + (progn + (guile-load-file (guile-buffer-file-name)) + (if guile-error-p + (progn + (throw 'exit nil))) + (let ((overlays scheme-buffer-overlays)) + (while overlays + (overlay-put (car overlays) 'modifiedp nil) + (setq overlays (cdr overlays))))) + ;; No - we have to send the overlays separately from top to bottom + (let ((overlays (reverse scheme-buffer-overlays))) + (if (or (= (point-min) (point-max)) + (not (eq (char-syntax (char-after (point-min))) ?\())) + (setq overlays (cdr overlays))) + (while overlays + (if (and (overlay-get (car overlays) 'modifiedp) + (not (overlay-get (car overlays) 'brokenp))) + (progn + (guile-send-overlay (guile-alloc-finfo (car overlays))) + (if guile-error-p (throw 'exit nil)))) + (setq overlays (cdr overlays))))) + (setq scheme-buffer-modified-p nil))) + (if guile-show-overlays-p + (guile-show-overlays)))) + +(defun guile-alloc-finfo (overlay) + (if (not (overlay-get overlay 'id)) + (progn + (let ((finfo (scheme-virtual-file-list-find (guile-buffer-file-name)))) + (if finfo + (setcdr finfo (delq overlay (cdr finfo))))) + (guile-new-finfo overlay)) + (let ((finfo (assq (overlay-get overlay 'id) + scheme-virtual-file-list))) + (if finfo + (let ((id (guile-alloc-virtual-id overlay))) + (setcar finfo id) + (overlay-put overlay 'id id) + (overlay-put overlay 'virtualp t) + finfo) + (guile-new-finfo overlay))))) + +(defun guile-new-finfo (overlay) + (let* ((id (guile-alloc-virtual-id overlay)) + (finfo (cons id (list overlay)))) + (overlay-put overlay 'id id) + (overlay-put overlay 'virtualp t) + (goto-char (overlay-start overlay)) + (overlay-put overlay 'original-line (guile-current-line)) + (setq scheme-virtual-file-list + (cons finfo scheme-virtual-file-list)) + finfo)) + +(defvar guile-last-prompt-end nil) +(defvar guile-input-sent-p t) + +(defun guile-send-input () + (interactive) + (if (and (marker-position guile-last-prompt-end) + scheme-ready-p) + (let ((start (save-excursion + (goto-char (point-max)) + (and (guile-real-safe-backward-sexp) + (point))))) + (if (not (and start + (<= (marker-position guile-last-prompt-end) start) + (guile-whitespace-between-p guile-last-prompt-end + start))) + (progn + (insert "\n") + (put-text-property (1- (point)) (point) 'face 'bold)) + (goto-char (point-max)) + (comint-send-input) + (setq guile-input-sent-p t))) + (comint-send-input))) + +(defconst guile-whitespace-chars " \t\n\r\f") + +(defun guile-whitespace-between-p (beg end) + (let ((beg (if (markerp beg) (marker-position beg) beg)) + (end (if (markerp end) (marker-position end) end))) + (if (> beg end) + (let ((swap beg)) + (setq beg end end swap))) + (save-excursion + (goto-char beg) + (skip-chars-forward guile-whitespace-chars end) + (= (point) end)))) + +;;*fixme* This is redundant code. Compare sync. +(defun guile-send-changes () + (interactive) + (setq guile-last-displayed-erring-overlay nil) + (setq guile-displayed-erring-buffers nil) + (setq guile-quiet nil) + (if (guile-check-all-1) + (progn + (setq guile-error-p nil) + (catch 'exit + (let ((old-buffer (current-buffer))) + (for-each (function + (lambda (buffer) + (set-buffer buffer) + (save-excursion + (goto-char (point-max)) + (let ((end (point))) + (beginning-of-buffer) + (guile-send-region (point) end nil t))) + (if guile-show-overlays-p + (guile-show-overlays)))) + (guile-get-enhanced-buffers)) + (set-buffer old-buffer)))))) + +(defun scheme-send-region (start end) + "Send the current region to the inferior Scheme process." + (interactive "r") + (if (not (guile-enhancedp (current-buffer))) + (progn + (comint-send-region (scheme-proc) start end) + (comint-send-string (scheme-proc) "\n")) + (setq guile-error-p nil) + (catch 'exit + (guile-send-region start end t) + (cond (guile-define-header-emitted-p + (message "Defined.")) + (guile-last-result + (guile-insert-before-prompt + (concat "RESULT: " guile-last-result "\n")) + (message "%s" (concat "Result: " guile-last-result))))) + (if guile-show-overlays-p + (guile-show-overlays)))) + +(defvar guile-define-name-marker) + +(defun guile-insert-before-prompt (string) + (save-excursion + (set-buffer scheme-buffer) + (save-excursion + (goto-char guile-last-prompt-end) + (forward-line 0) ;; ignore field boundary + (let ((inhibit-read-only t) + (before-prompt (point)) + (w (or (get-buffer-window scheme-buffer 'visible) + (get-buffer-window scheme-buffer t)))) + (let ((w-start (and w (window-start w)))) + (insert-before-markers string) + (if (and w (= before-prompt w-start)) + (let ((selected (selected-window))) + (unwind-protect + (progn + (select-window w) + (recenter)) + (select-window selected) + (set-buffer scheme-buffer))))))))) + +(defvar guile-define-header-emitted-p nil) +(defvar guile-define-startcol 0) +(defvar guile-define-filler "") +(defvar guile-define-fillcol 0) +(defvar guile-last-result nil) + +(defun guile-send-region (start end send-all-p &optional multip) + (if (not scheme-ready-p) + (error "Scheme is not ready to receive expressions from Emacs.")) + (let ((overlays (reverse scheme-buffer-overlays))) + (if (or (= (point-min) (point-max)) + (not (eq (char-syntax (char-after (point-min))) ?\())) + (setq overlays (cdr overlays))) + ;; First skip some overlays + (while (and overlays (<= (overlay-end (car overlays)) start)) + (setq overlays (cdr overlays))) + (setq guile-define-header-emitted-p nil) + (setq guile-last-result nil) + (let ((start (max start (overlay-start (car overlays))))) + (if (/= start (overlay-start (car overlays))) + (guile-send-overlay (save-excursion + (guile-alloc-finfo (car overlays))) + t + multip + start + end) + (while (and overlays + (< (overlay-start (car overlays)) end)) + (if (and (not (overlay-get (car overlays) 'brokenp)) + (or send-all-p + (overlay-get (car overlays) 'modifiedp))) + (guile-send-overlay (save-excursion + (guile-alloc-finfo (car overlays))) + t + multip)) + (setq overlays (cdr overlays))))))) + +(defconst guile-end-of-chunk "\001\n") + +;; *fixme* Improve code. +(defun guile-send-overlay (finfo &optional interactivep multip start end) + (let* ((filename (car finfo)) + (overlay (car (cdr finfo))) + (module-overlay (overlay-get overlay 'module-overlay)) + (module (or (and module-overlay + (overlay-get module-overlay 'define-module)) + "#f")) + (old-buffer (current-buffer)) + (old-pos (point))) + + ;; Define the module of the overlay if not done before + (if (and module-overlay + (overlay-get module-overlay 'modifiedp)) + (guile-send-overlay (save-excursion + (guile-alloc-finfo module-overlay)))) + + (set-buffer scheme-buffer) + ;; Inhibit process output and hamster it + (setq comint-allow-output-p nil) + (setq guile-eval-output nil) + (setq guile-unallowed-output "") + + (set-buffer old-buffer) + ;; Turn on runlight + (scheme-enter-load) + ;; Send load command + (comint-send-string + (scheme-proc) + (if start + (let ((column (save-excursion + (goto-char start) + (current-column)))) + (format "(%%%%emacs-load %S %d %d '%s #%c)\n" + filename + (+ (overlay-get overlay 'original-line) + -1 + (count-lines (overlay-get overlay 'original-line) + start) + (if (zerop column) 0 -1)) + column + module + (if interactivep ?t ?f))) + (format "(%%%%emacs-load %S %d %d '%s #%c)\n" + filename + (1- (overlay-get overlay 'original-line)) + 0 + module + (if interactivep ?t ?f)))) + ;; Send overlay contents + (comint-send-string + (scheme-proc) + (buffer-substring (or start (overlay-start overlay)) + (or end (overlay-end overlay)))) + ;; If this is the last overlay we may have to send a final newline + ;;(if (and (eq overlay scheme-buffer-last-overlay) + ;; (/= (overlay-start overlay) + ;; (overlay-end overlay)) + ;; (not (eq (char-after (1- (overlay-end overlay))) ?\n))) + (comint-send-string (scheme-proc) "\n") + ;; Remove modified mark so that Emacs will trust its idea about positions. + (or start (overlay-put overlay 'modifiedp nil)) + ;; Send end-of-text + (comint-send-string (scheme-proc) guile-end-of-chunk) + ;; Wait for acknowledge. + (while (and scheme-load-p (not guile-error-p)) + (accept-process-output (scheme-proc) 0 guile-process-timeout)) + + ;; Have we received an error? + (if guile-error-p + (progn + (if interactivep + (save-excursion + (set-buffer scheme-buffer) + (let ((output guile-unallowed-output)) + (if (string-match "\\(^ABORT:.*\n\\)+" output) + (guile-insert-before-prompt (match-string 1 output)))))) + (overlay-put overlay 'modifiedp t) + (setq scheme-load-p nil) + (throw 'exit nil))) ;Abort whatever we was doing. + + ;; The transfer has been successful. Display defined symbol. + (if interactivep + (progn + (goto-char (overlay-start overlay)) + (if (and (not (and start (/= start (overlay-start overlay)))) + (looking-at guile-defexpr)) + (progn + (guile-display-name (match-string guile-defexpr-name) + multip) + (setq guile-last-result nil)) + (set-buffer scheme-buffer) + (if guile-eval-output + (guile-insert-before-prompt guile-eval-output)) + (setq guile-last-result guile-eval-result) + (set-buffer old-buffer)) + (goto-char old-pos) + (sit-for 0)) + + (goto-char old-pos)))) + +(defun guile-display-name (name multip) + (save-excursion + (let ((buffer-file (guile-buffer-file-name)) + (buffer-name (buffer-name))) + (set-buffer scheme-buffer) + (save-excursion + (let ((inhibit-read-only t)) + (if (not guile-define-header-emitted-p) + (let ((header + (format "DEFINED:%s ()\n" + (if multip + (concat " " + (or (and buffer-file + (file-name-nondirectory + buffer-file)) + buffer-name)) + "")))) + (guile-insert-before-prompt header) + (set-marker guile-define-name-marker + (save-excursion + (goto-char guile-last-prompt-end) + (forward-line 0) + (- (point) 2))) + (setq guile-define-startcol (- (length header) 2)) + (setq guile-define-filler + (concat "\n" + (make-string guile-define-startcol ? ))) + (setq guile-define-fillcol + (let ((window (get-buffer-window scheme-buffer t))) + (if window + (- (window-width window) 3) + fill-column))) + (setq guile-define-header-emitted-p t))) + (goto-char guile-define-name-marker) + (cond ((= (current-column) guile-define-startcol)) + ((> (+ (current-column) (length name)) guile-define-fillcol) + (insert-before-markers guile-define-filler)) + (t (insert-before-markers " "))) + (insert-before-markers name)))))) + +;;; Enhanced editing +;;; + +(defvar guile-n-enhanced-buffers 0 + "Number of buffers in enhanced edit mode.") + +(defun guile-enhancedp (&optional buffer) + (interactive) + (if (not buffer) + scheme-buffer-overlays + (save-excursion + (set-buffer buffer) + scheme-buffer-overlays))) + +(defun guile-get-enhanced-buffers () + (let ((ls (buffer-list)) + (ans '())) + (while ls + (if (guile-enhancedp (car ls)) + (setq ans (cons (car ls) ans))) + (setq ls (cdr ls))) + (reverse ans))) + +(defun guile-enhanced-edit (buffer &optional known-by-scheme) + "Put the current scheme buffer into enhanced editing mode." + (interactive (list (current-buffer))) + (if (guile-enhancedp buffer) + (error "Already in enhanced editing mode!")) + (save-excursion + (set-buffer buffer) + (guile-parse-buffer known-by-scheme) + (setq scheme-overlay-repair-function 'guile-repair-overlays) + (if (not (memq scheme-overlay-repair-idle-timer timer-idle-list)) + (setq scheme-overlay-repair-idle-timer + (run-with-idle-timer 0.1 t 'run-hook-with-args + 'scheme-overlay-repair-function))) + (setq guile-n-enhanced-buffers (1+ guile-n-enhanced-buffers))) + (force-mode-line-update)) + +(defun guile-normal-edit (buffer) + "Exit enhanced editing mode." + (interactive (list (current-buffer))) + (if (guile-attachedp) + (error "Can't exit enhanced editing mode while attached to scheme. Detach first.")) + (save-excursion + (set-buffer buffer) + (for-each (function (lambda (overlay) + (if (overlayp overlay) ; For stability's sake + (progn + (if (guile-virtual-p overlay) + (scheme-virtual-unlink (overlay-get overlay 'id))) + (delete-overlay overlay))))) + scheme-buffer-overlays) + (setq scheme-buffer-overlays ()) + (setq scheme-buffer-last-overlay nil) + ;; Since we let go of the control, we have to mark the buffer... + ;(setq scheme-buffer-modified-p t) Now using first-change-hook. + (setq scheme-overlay-repair-function nil) + (scheme-virtual-unlink (guile-buffer-file-name buffer)) + (setq guile-n-enhanced-buffers (1- guile-n-enhanced-buffers))) + (force-mode-line-update)) + +;;; Overlay lists +;;; +;;; Every non-broken overlay containing a sexp starts with a character +;;; with syntax ?\(. +;;; The first overlay in the overlay list is never broken. + +(defun guile-current-line () + (+ (count-lines 1 (point)) + (if (= (current-column) 0) 1 0))) + +(defun guile-safe-forward-sexp () + "Move point one sexp forwards. +Returns non-nil if no error was encountered." + (not (condition-case err + (forward-sexp) + (error err)))) + +(defun guile-safe-backward-sexp () + "Move point one sexp forwards. +Returns non-nil if no error was encountered." + (not (condition-case err + (backward-sexp) + (error err)))) + +(defun guile-real-safe-backward-sexp () + (and (guile-safe-backward-sexp) + (progn + (and (char-before) + (char-before (1- (point))) + (eq (char-before (1- (point))) ?#) + (eq (char-syntax (char-before)) ?w) + (forward-char -2)) + t))) + +(defun guile-parse-buffer (&optional initialp) + (interactive) + (if (= (point-min) (point-max)) + ;; Apparently, the buffer is empty + (progn + (setq overlay (make-overlay (point-min) (point-max) nil nil t)) + (overlay-put overlay 'modification-hooks + '(guile-handle-modification)) + (overlay-put overlay 'insert-behind-hooks + '(rear-sticky-overlay-function guile-handle-modification)) + (setq scheme-buffer-overlays (list overlay)) + (setq scheme-buffer-last-overlay overlay)) + (setq scheme-buffer-last-overlay nil) + (guile-reparse-buffer nil (point-min) initialp) + (guile-modularize scheme-buffer-overlays))) + +(defvar guile-tail-cons (cons nil nil)) + +(defun guile-cons-before-match (x ls) + "Match X against successive elements of LS. +Return cons before the one with car matching X." + (if (or (null ls) + (eq (car ls) x)) + nil + (while (and (cdr ls) (not (eq (car (cdr ls)) x))) + (setq ls (cdr ls))) + (and (cdr ls) + ls))) + +;; Here I've sacrificed readability for speed... +;; Geeh! What a monstrum! +;; +(defun guile-reparse-buffer (start-overlay limit &optional initialp) + "Reparse buffer backwards to build/update `scheme-buffer-overlays'. +Start with overlay START-OVERLAY. Stop when we have passed LIMIT. +If START-OVERLAY is nil parsing starts from (point-max). +The optional third argument INITIALP should be non-nil if parsing +for the first time. This will cause initialization of the +original-line property." + (let* ((tailp (and start-overlay + (progn + (goto-char (overlay-end start-overlay)) + (if (bolp) + (guile-cons-before-match start-overlay + scheme-buffer-overlays) + (let ((after (guile-cons-before-match + start-overlay + scheme-buffer-overlays))) + (if after + (progn + (overlay-put (car after) 'brokenp t) + (guile-cons-before-match + after + scheme-buffer-overlays)))))))) + (tail (or tailp guile-tail-cons)) + (overlays (if tailp (cdr tail) scheme-buffer-overlays)) + (overlay nil) + (first-broken nil) + (last-broken nil) + (last-end (if tailp + (overlay-end (car (cdr tail))) + (point-max)))) + (goto-char last-end) + ;; Parse buffer backwards... + (save-match-data + (while (> (point) limit) + ;; First try to move one sexp backwards... + (if (and (guile-safe-backward-sexp) + (bolp)) + (progn + ;; Do we have it in the list? + (while (and overlays + (> (overlay-start (car overlays)) (point))) + ;; First throw away some trash overlays... + (let ((id (overlay-get (car overlays) 'id))) + (delete-overlay (car overlays)) + (if id + ;; It's a stand-alone sexp, remove it from the list + (scheme-virtual-unlink id))) + (setq overlays (cdr overlays))) + (if (and overlays + (= (overlay-start (car overlays)) (point))) + ;; Yes! + (progn ; Is it intact? + (if (or (overlay-get (car overlays) 'brokenp) + (/= (overlay-end (car overlays)) last-end)) + ;; No... + (progn + ;; Adjust it. + (move-overlay (car overlays) (point) last-end) + ;; Can we repair it? + (if (if (bobp) + (or (eolp) + (eq (char-syntax (following-char)) ?\() + (eq (char-syntax (following-char)) ?<) + (eq (char-syntax (following-char)) ? )) + (eq (char-syntax (following-char)) ?\()) + ;; Yes! + (progn + (overlay-put (car overlays) 'brokenp nil) + (overlay-put (car overlays) 'face nil) + (overlay-put (car overlays) 'modifiedp t) + (overlay-put (car overlays) + 'define-module + (and (looking-at "(define-module \\((.*)\\)") + (condition-case err + (save-excursion + (goto-char (match-beginning 1)) + (read (current-buffer))) + (error nil))))) + ;; No... + (overlay-put (car overlays) 'face guile-broken-face) + (overlay-put (car overlays) 'modifiedp t)))) + ;; Link it in. + (setcdr tail overlays) + (setq tail (cdr tail)) + (setq overlays (cdr overlays))) + ;; We probably have to make a new overlay... + ;; First check if it's OK. + (if (if (bobp) + (or (eolp) + (eq (char-syntax (following-char)) ?\() + (eq (char-syntax (following-char)) ?<) + (eq (char-syntax (following-char)) ? )) + (eq (char-syntax (following-char)) ?\()) + ;; Everything seems OK with this one. + (progn + (setq overlay (make-overlay (point) last-end nil nil t)) + (if initialp + (overlay-put overlay 'original-line + (guile-current-line)) + (overlay-put overlay 'modifiedp t)) + (overlay-put overlay 'modification-hooks + '(guile-handle-modification)) + (overlay-put overlay + 'define-module + (and (looking-at "(define-module \\((.*)\\)") + (condition-case err + (save-excursion + (goto-char (match-beginning 1)) + (read (current-buffer))) + (error nil)))) + ;; And link it in... + (setcdr tail (cons overlay overlays)) + (setq tail (cdr tail))) + ;; But this one is broken! + ;; Try to find some structure... + (guile-backward-broken-sexp) + (while (and overlays + (> (overlay-start (car overlays)) (point))) + (let ((id (overlay-get (car overlays) 'id))) + (delete-overlay (car overlays)) + (if id + (scheme-virtual-unlink id))) + (setq overlays (cdr overlays))) + ;; Is it possibly the first one in the overlay list? + (if (and overlays + (= (overlay-start (car overlays)) (point))) + (progn + ;; Adjust it. + (move-overlay (car overlays) (point) last-end) + (overlay-put (car overlays) 'face guile-broken-face) + (overlay-put (car overlays) 'modifiedp t) + ;; Link it in. + (setcdr tail overlays) + (setq tail (cdr tail)) + (setq overlays (cdr overlays))) + ;; It wasn't - make a new overlay. + (setq overlay (make-overlay (point) last-end nil nil t)) + (overlay-put overlay 'brokenp t) + (overlay-put overlay 'face guile-broken-face) + (overlay-put overlay 'modification-hooks + '(guile-handle-modification)) + ;; And link it in... + (setcdr tail (cons overlay overlays)) + (setq tail (cdr tail)))))) + ;; Broken overlay... Here we go again! + (guile-backward-broken-sexp) + (while (and overlays + (> (overlay-start (car overlays)) (point))) + (let ((id (overlay-get (car overlays) 'id))) + (delete-overlay (car overlays)) + (if id + (scheme-virtual-unlink id))) + (setq overlays (cdr overlays))) + (if (and overlays + (= (overlay-start (car overlays)) (point))) + (progn + (setq overlay (car overlays)) + (move-overlay overlay (point) last-end) + (setcdr tail overlays) + (setq tail (cdr tail)) + (setq overlays (cdr overlays))) + (setq overlay (make-overlay (point) last-end nil nil t)) + (overlay-put overlay 'modification-hooks + '(guile-handle-modification)) + (setcdr tail (cons overlay overlays)) + (setq tail (cdr tail))) + (overlay-put overlay 'brokenp t) + (overlay-put overlay 'face guile-broken-face)) + (if (overlay-get (car tail) 'brokenp) + (progn + (setq first-broken (car tail)) + (if (not last-broken) + (setq last-broken (car tail))))) + (setq last-end (point)))) + (if (not tailp) + (progn + (setq scheme-buffer-overlays + (cdr guile-tail-cons)) + ;; Don't let the rear-stickiness propagate upwards... + (if scheme-buffer-last-overlay + (if (not (eq (car scheme-buffer-overlays) + scheme-buffer-last-overlay)) + (progn + (overlay-put scheme-buffer-last-overlay + 'insert-behind-hooks + nil) + (overlay-put (car scheme-buffer-overlays) + 'insert-behind-hooks + '(rear-sticky-overlay-function + guile-handle-modification)))) + (overlay-put (car scheme-buffer-overlays) + 'insert-behind-hooks + '(rear-sticky-overlay-function guile-handle-modification))) + (setq scheme-buffer-last-overlay + (car scheme-buffer-overlays)))) + (setq guile-last-broken last-broken) + (setq guile-repair-limit + (if first-broken + ;(overlay-start + ; (let ((ovls (memq first-broken scheme-buffer-overlays))) + ; (or (and ovls (cdr ovls) (car (cdr ovls))) + ; first-broken) + (overlay-start first-broken) + guile-big-integer))) + (if guile-show-overlays-p + (guile-show-overlays)) + ) + +(defvar guile-last-broken nil) +(defvar guile-repair-limit guile-big-integer) + +(defun guile-handle-modification (overlay after from to &optional length) + (if after + (progn + (overlay-put overlay 'brokenp t) + (setq scheme-buffer-overlays-modified-p t) + (if guile-last-broken + (if (< (overlay-start overlay) guile-repair-limit) + (setq guile-repair-limit + ;(overlay-start + ; (let ((ovls (memq overlay scheme-buffer-overlays))) + ; (or (and ovls (cdr ovls) (car (cdr ovls))) + ; overlay))) + (overlay-start overlay)) + (if (> (overlay-start overlay) + (overlay-start guile-last-broken)) + (setq guile-last-broken overlay))) + (setq guile-last-broken overlay) + (setq guile-repair-limit + ;(overlay-start + ; (let ((ovls (memq overlay scheme-buffer-overlays))) + ; (or (and ovls (cdr ovls) (car (cdr ovls))) + ; overlay))) + (overlay-start overlay)))))) + +(defun guile-repair-overlays () + (if (and (eq major-mode 'scheme-mode) + scheme-buffer-overlays-modified-p) + (save-excursion + ;(ding) + ;(message "Repair!") + (setq scheme-buffer-modified-p t) + (if scheme-associated-process-buffer + (setq guile-synchronizedp nil)) + (guile-reparse-buffer guile-last-broken guile-repair-limit) + (guile-modularize scheme-buffer-overlays) + (setq scheme-buffer-overlays-modified-p nil)))) + +(defun guile-modularize (r-overlays) + (let ((overlays (reverse r-overlays)) + (module nil)) + (while overlays + (if (overlay-get (car overlays) 'define-module) + (progn + (overlay-put (car overlays) 'module-overlay nil) + (setq module (car overlays))) + (overlay-put (car overlays) 'module-overlay module)) + (setq overlays (cdr overlays))))) + +(defun guile-backward-broken-sexp () + (interactive) + (beginning-of-line) + (let ((last (point))) + (while (not (or (bobp) + (and (eq (following-char) ?\() + (guile-safe-backward-sexp) + (bolp)))) + (forward-line -1) + (beginning-of-line) + (setq last (point))) + (let ((end (point))) + (goto-char (if (guile-safe-forward-sexp) + last + end))))) + +;; rear-sticky-overlay-function: +;; Put this function in the `insert-behind-hooks' of an overlay +;; in order to make the overlay rear-sticky. + +(defun rear-sticky-overlay-function (overlay after from to &optional length) + (if after + (move-overlay overlay (overlay-start overlay) to))) + +;;; Some debugging utilities +;;; + +(defvar guile-show-overlays-p nil) + +(defun guile-show-overlays () + (interactive) + (if (guile-enhancedp) + (let ((n 1) + (color nil) + (previous nil) + (overlays scheme-buffer-overlays)) + (if (null overlays) + (progn + (ding) + (message "Empty overlay list!")) + (if (not (memq 'rear-sticky-overlay-function + (overlay-get (car overlays) 'insert-behind-hooks))) + (progn + (ding) + (message "Last overlay not rear-sticky!"))) + (while overlays + (overlay-put (car overlays) + 'face + (if (setq color (not color)) + (if (overlay-get (car overlays) 'brokenp) + guile-broken-face-1 + (if (overlay-get (car overlays) 'modifiedp) + guile-modified-face-1 + guile-unmodified-face-1)) + (if (overlay-get (car overlays) 'brokenp) + guile-broken-face-2 + (if (overlay-get (car overlays) 'modifiedp) + guile-modified-face-2 + guile-unmodified-face-2)))) + (if previous + (progn + (if (/= (overlay-end (car overlays)) + (overlay-start previous)) + (progn (ding) + (message "Bad end boundary at overlay no. %d" n))) + (if (overlay-get (car overlays) 'insert-behind-hooks) + (progn + (ding) + (message "Inner overlay no. %d rear-sticky!" n))))) + (setq previous (car overlays)) + (setq n (1+ n)) + (setq overlays (cdr overlays))) + (if (/= (overlay-start previous) (point-min)) + (progn + (ding) + (message "First overlay doesn't start at %d" (point-min))))))) + (setq guile-show-overlays-p t)) + +(defun guile-hide-overlays () + (interactive) + (let ((color nil) + (overlays scheme-buffer-overlays)) + (while overlays + (overlay-put (car overlays) + 'face + (if (overlay-get (car overlays) 'brokenp) + guile-broken-face + nil)) + (setq overlays (cdr overlays)))) + (setq guile-show-overlays-p nil)) + +;; *fixme* Consider removing this function +(defun guile-kill-overlays (&optional ls) + (interactive) + (if (not ls) + (progn + (setq ls (apply (function append) + (mapcar (function cdr) + scheme-virtual-file-list))) + (setq scheme-virtual-file-list ()))) + (while ls + (delete-overlay (car ls)) + (setq ls (cdr ls)))) + +;; *fixme* Consider removing this function +(defun overlay-kill () + (interactive) + (delete-overlay (car (overlays-at (point))))) + +(defun for-each (func ls) + (while ls + (funcall func (car ls)) + (setq ls (cdr ls)))) + + +;;; Completion + +(defconst guile-symbol-chars "---A-ZÅÄÖa-zåäö0-9!$%&/=?@+*<>|-_:.") + +(defun guile-match-symnames (word &optional exactp) + (if (not word) + '() + (save-excursion + (set-buffer scheme-buffer) + (guile-eval `(map symbol->string + (%%apropos-internal + ,(concat "^" + (regexp-quote word) + (and exactp "$")))))))) + +(defmacro guile-force-splittable (&rest forms) + `(let ((f (selected-frame)) + (w (selected-window))) + (let ((unsplittable (assq 'unsplittable (frame-parameters f))) + (dedicatedp (window-dedicated-p w)) + (same-window-buffer-names + (append same-window-buffer-names + (list (buffer-name (window-buffer w)))))) + (unwind-protect + (progn + (modify-frame-parameters f '((unsplittable . nil))) + (set-window-dedicated-p w nil) + ,@forms) + (modify-frame-parameters f (list unsplittable)) + (set-window-dedicated-p w dedicatedp))))) + +(defvar guile-complete-function 'comint-dynamic-complete) + +(defun guile-indent-or-complete () + (interactive) + (let ((beg (save-excursion + (beginning-of-line) + (point)))) + (if (guile-whitespace-between-p beg (point)) + (funcall 'indent-for-tab-command) + (funcall guile-complete-function)))) + +(defun guile-complete-symbol () + (interactive) + (let ((word (comint-word guile-symbol-chars))) + (if word + (progn + (guile-force-splittable + (comint-dynamic-simple-complete word (guile-match-symnames word))) + (if (string= (buffer-name) scheme-buffer) + (put-text-property comint-last-output-start + (point) 'face 'bold)))))) + +(defun guile-list-completions () + (interactive) + (let* ((word (comint-word guile-symbol-chars)) + (candidates (mapcar (function (lambda (x) (list x))) + (guile-match-symnames word))) + (completions (all-completions word candidates))) + (if (null completions) + (message "No completions of %s" word) + (guile-force-splittable + (comint-dynamic-list-completions completions)) + (if (string= (buffer-name) scheme-buffer) + (put-text-property comint-last-output-start (point) 'face 'bold))))) + +;;; Documentation + +(defun guile-documentation-symbols () + (save-excursion + (set-buffer scheme-buffer) + (guile-eval '(map symbol->string (%%apropos-internal ""))))) + +(defun guile-variable-at-point (symnames) + (condition-case () + (let ((stab (syntax-table))) + (unwind-protect + (save-excursion + (set-syntax-table scheme-mode-syntax-table) + (or (not (zerop (skip-syntax-backward "_w"))) + (eq (char-syntax (following-char)) ?w) + (eq (char-syntax (following-char)) ?_) + (forward-sexp -1)) + (skip-chars-forward "'") + (let ((obj (read (current-buffer)))) + (and (symbolp obj) (member (symbol-name obj) symnames) obj))) + (set-syntax-table stab))) + (error nil))) + +(defun guile-describe-variable (variable) + "Display the full documentation of Guile variable VARIABLE." + (interactive + (let ((symnames (guile-documentation-symbols))) + (let ((symbol (guile-variable-at-point symnames)) + (enable-recursive-minibuffers t) + val) + (setq val (completing-read (if symbol + (format "Describe Guile variable (default %s): " symbol) + "Describe Guile variable: ") + (mapcar (lambda (s) + (cons s '())) + symnames) + nil t)) + (list (if (equal val "") + symbol + (intern val)))))) + (guile-force-splittable + (with-output-to-temp-buffer "*Help*" + (prin1 variable) + (princ ": ") + (princ (save-excursion + (set-buffer scheme-buffer) + (guile-eval variable t))) + (terpri) + (terpri) + (let ((doc (save-excursion + (set-buffer scheme-buffer) + (guile-eval `(%%emacs-symdoc ',variable))))) + (if doc + (princ doc) + (princ "not documented"))) + (print-help-return-message) + (save-excursion + (set-buffer standard-output) + (help-mode) + ;; Return the text we displayed. + (buffer-string))))) + +(provide 'guile) +(run-hooks 'guile-load-hook) hunk ./site-lisp/guileint-1.5/guileint.el 1 +;;; NAME: guileint.el +;;; SYNOPSIS: A Guile/Emacs interface prototype +;;; VERSION: 1.5 +;;; LAST CHANGE: 2002-10-19 +;;; CREATED: 1997-07-17 +;;; AUTHOR: Mikael Djurfeldt +;;; COPYRIGHT: (C) 1997, 2002 Mikael Djurfeldt +;;; +;;; Verbatim copies of this file may be freely redistributed. +;;; +;;; Modified versions of this file may be redistributed provided that this +;;; notice remains unchanged, the file contains prominent notice of +;;; author and time of modifications, and redistribution of the file +;;; is not further restricted in any way. +;;; +;;; This file is distributed `as is', without warranties of any kind. +;;; +;;; REQUIREMENTS: +;;; +;;; USAGE: +;;; +;;; BUGS: +;;; +;;; +;;; Setup load-path + +(if (featurep 'guileint) + nil + +(require 'cl-19 "cl") + +(defconst guileint-init-file "guileint") + +(defvar guileint-emacs-dir nil) +(let ((pathlist (getenv "EMACSSITELOAD"))) + (if (and pathlist + (string-match (concat "\\(\\(/[^:/]+\\)*\\)/?" + guileint-init-file + "\\(\.elc?\\)?\\(:\\|\\'\\)") + pathlist)) + (setq guileint-emacs-dir (match-string 1 pathlist)))) + +(defvar guileint-default-load-path load-path) +(setq load-path + (append (list + guileint-emacs-dir + ) + guileint-default-load-path + '( + ))) + +(setq scheme-program-name + (let ((v (getenv "SCHEME_PROGRAM_NAME"))) + (or v + (concat "guile" + (and window-system " --emacs"))))) + +;;; Select buffers to pop up as separate windows +(if window-system + (progn + (defvar default-special-display-buffer-names + special-display-buffer-names) + (setq special-display-buffer-names + (union default-special-display-buffer-names '("*scheme*"))) + + (setq same-window-buffer-names + (delete "*scheme*" same-window-buffer-names)) + + (setq special-display-frame-alist + '((height . 24) (width . 80) (unsplittable . t))) + )) + +;;; Do things to support lisp-hacking better +(if (equal (substring emacs-version 0 2) "19") + ;; Emacs version 19 specific initializations + (progn + (copy-face 'default 'paren) + (condition-case err + (make-face-bold 'paren) + (error)) + (setq show-paren-face 'paren) + (require 'paren) + ;; The old parenthesis matcher has the advantage of displaying + ;; non-visible matching parenthesis in the minibuffer. + ;; Since paren.el adds (setq blink-paren-function nil) to the + ;; window-setup-hook it's necessary to put this setq there + ;; also. + (add-hook 'window-setup-hook (function restore-blink-paren) t) + (setq blink-matching-delay 0.5) + )) + +(defun restore-blink-paren () + (interactive) + (setq blink-matching-paren-on-screen t) + (set-face-underline-p 'paren t)) + +;;; Menus +;;; + +(require 'defmenu) + +;(setq menu-bar-final-items +; '(completion inout signals scheme help-menu)) +(setq menu-bar-final-items + '(interpret scheme help-menu)) + +;; The global menu +;; +(define-menu global-map 'interpret "Interpret" + '(("Guile" run-scheme (not (comint-check-proc "*scheme*"))) + ("Switch to *scheme*" guile-switch-to-scheme + (comint-check-proc "*scheme*")))) + +(load "inda-scheme") + +(provide 'guileint) +) hunk ./site-lisp/guileint-1.5/hilit-scheme.el 1 - +(if (not (fboundp 'hilit-extend-face-translation-table)) + (defun hilit-extend-face-translation-table (face-table) + (let ((index (or (and (x-display-color-p) + (cdr (assq hilit-background-mode + '((light . 1) (dark . 2))))) + 3))) + (mapcar (function + (lambda (x) + (let ((entry (assq (car x) hilit-face-translation-table))) + (if entry + (setcdr entry (nth index x)) + (setq hilit-face-translation-table + (cons (cons (car x) (nth index x)) + hilit-face-translation-table)))))) + face-table))) +) + +(hilit-extend-face-translation-table + '((predicate violetred purple nil) + (mutator red red nil))) + +(hilit-set-mode-patterns + '(scheme-mode inferior-scheme-mode) + '((";.*" nil comment) + (hilit-string-find ?\\ string) + ("^\\s *(define\\(-syntax\\|-class\\)?\\([ \t]*[\n]?[ \t]*\\(([^()]*)\\|[^ \t\n()]+\\)\\)?" () defun) + ("^\\s *(\\(provide\\|require\\|load\\).*$" nil include) + ("\\s *\\&\\(rest\\|optional\\)\\s *" nil decl) ; keyword + ("(\\(else\\|unquote\\(-splicing\\)?\\|quote\\|lambda\\|lambda\\*\\|if\\|begin\\|cond\\|and\\|or\\|case\\|let\\*?\\|letrec\\|do\\|delay\\|quasiquote\\)[ \t\n]" 1 decl) ; keyword + ("(\\([^ \t\n(]+\\?\\)" 1 predicate) + ("(\\([^ \t\n(]+!\\)" 1 mutator) + )) + hunk ./site-lisp/guileint-1.5/inda-c.el 1 +;;; NAME: inda-c.el +;;; SYNOPSIS: Customizations of c-mode for the INDA course at NADA/KTH +;;; VERSION: 1.0 +;;; LAST CHANGE: 950827 +;;; CREATED: 950827 +;;; AUTHOR: Mikael Djurfeldt +;;; COPYRIGHT: (C) 1995 Mikael Djurfeldt +;;; +;;; Verbatim copies of this file may be freely redistributed. +;;; +;;; Modified versions of this file may be redistributed provided that this +;;; notice remains unchanged, the file contains prominent notice of +;;; author and time of modifications, and redistribution of the file +;;; is not further restricted in any way. +;;; +;;; This file is distributed `as is', without warranties of any kind. +;;; +;;; REQUIREMENTS: +;;; +;;; USAGE: +;;; +;;; BUGS: +;;; + +(require 'defmenu) + +;; A better C mode. +(fmakunbound 'c-mode) +(makunbound 'c-mode-map) +(fmakunbound 'c++-mode) +(makunbound 'c++-mode-map) +(makunbound 'c-style-alist) + +(autoload 'c++-mode "cc-mode" "C++ Editing Mode" t) +(autoload 'c-mode "cc-mode" "C Editing Mode" t) + +(setq auto-mode-alist + (append '(("\\.C$" . c++-mode) + ("\\.cc$" . c++-mode) + ("\\.c$" . c-mode) + ("\\.h$" . c-mode) + ) auto-mode-alist)) + +(defvar inda-c-menu-fixed-p nil) + +;; And tweak it to fit ckod. +(defun inda-c-mode-common-initialize () + (if (assoc 'substatement-open c-offsets-alist) + (c-set-offset 'substatement-open 0) + (c-set-offset 'block-open 'c-adaptive-block-open)) + (c-set-offset 'brace-list-open '+) + (c-set-offset 'arglist-cont '+) + ;; Fix the "C" menu... + (if (not inda-c-menu-fixed-p) + (progn + (fset 'c-advanced-menu (lookup-key c-mode-map [menu-bar c])) + (define-menu c-mode-map 'c "C" + '( + ("Compile" compile) + () + ("Indent buffer" indent-buffer) + ("Indent region" indent-region) + ("Indent definition" indent-defun) + () + ("Next Error" next-error) + ("Previous Error" previous-error) + ("First Error" first-error) + () + ("Advanced" c-advanced-menu) + )) + (setq inda-c-menu-fixed-p t)))) + +(add-hook 'c-mode-common-hook 'inda-c-mode-common-initialize) hunk ./site-lisp/guileint-1.5/inda-scheme.el 1 +;;; NAME: inda-scheme.el +;;; SYNOPSIS: Customizations of the scheme modes for +;;; the INDA course at NADA/KTH +;;; VERSION: 1.0 +;;; LAST CHANGE: 950827 +;;; CREATED: 950827 +;;; AUTHOR: Mikael Djurfeldt +;;; COPYRIGHT: (C) Mikael Djurfeldt 1995 +;;; +;;; Verbatim copies of this file may be freely redistributed. +;;; +;;; Modified versions of this file may be redistributed provided that this +;;; notice remains unchanged, the file contains prominent notice of +;;; author and time of modifications, and redistribution of the file +;;; is not further restricted in any way. +;;; +;;; This file is distributed `as is', without warranties of any kind. +;;; +;;; REQUIREMENTS: +;;; +;;; USAGE: +;;; +;;; BUGS: +;;; +;;; + +(require 'guile-init) + +;;; Customizations of the scheme modes + +(defun inda-scheme-mode-initializations () + (define-key scheme-mode-map "\r" 'newline-and-indent) + ;(define-key scheme-mode-map "\C-c\C-e" 'scheme-send-definition-and-go) + (define-key scheme-mode-map [S-mouse-2] 'guile-frame-eval-at-click) + (define-key scheme-mode-map [triple-mouse-1] 'inda-mark-sexp) ;*fixme* + (define-key scheme-mode-map "\C-c\C-b" 'scheme-send-buffer) + (define-key scheme-mode-map "(" 'scheme-electric-open-paren) + (define-key scheme-mode-map "[" 'scheme-electric-open-paren) + (define-key scheme-mode-map ")" 'scheme-close-paren) + (define-key scheme-mode-map "]" 'scheme-close-paren) + (define-key scheme-mode-map "\M-?" 'guile-list-completions) + (define-key scheme-mode-map "\C-cd" 'guile-describe-variable) + (define-key scheme-mode-map "\M-\t" 'guile-complete-symbol) + (put 'procedure->macro 'scheme-indent-function 0) + (put 'procedure->memoizing-macro 'scheme-indent-function 0) + (put 'bind 'scheme-indent-function 1) + (put 'letrec* 'scheme-indent-function 1) + (put 'syntax-rules 'scheme-indent-function 1) + (put 'syntax-case 'scheme-indent-function 2) + (put 'define-syntax 'scheme-indent-function 1) + (put 'with-syntax 'scheme-indent-function 1)) + +(add-hook 'scheme-mode-hook (function inda-scheme-mode-initializations)) + +(defun scheme-electric-open-paren () + (interactive) + (insert last-input-char) + (let ((old-point (point))) + (indent-for-tab-command) + (if (not (eq (char-after (1- (point))) last-input-char)) + (goto-char old-point)))) + +(defun scheme-close-paren () + (interactive) + (insert last-input-char) + (if (guile-enhancedp) + (guile-repair-overlays)) + (if blink-paren-function + (funcall blink-paren-function))) + +(defun inda-send-definition (click) + "Position point and send definition to the inferior Scheme process." + (interactive "e") + (mouse-set-point click) + (sit-for 0) + (scheme-send-definition)) + +(defun inda-mark-sexp () + (interactive) + (beginning-of-defun) + (mark-sexp)) + +(defvar inda-read-only-overlay nil) + +(defun inda-inferior-initializations () + (setq guile-kill-buffer-on-death t) + ;; The following seems already to be done in comint-mode... + ;;(add-hook 'pre-command-hook (function comint-preinput-scroll-to-bottom)) + (setq comint-scroll-to-bottom-on-input 'this) + (setq comint-scroll-to-bottom-on-output nil) + + ;; Some key bindings. + (define-key inferior-scheme-mode-map "\C-a" 'comint-bol) + (define-key inferior-scheme-mode-map [C-a] 'comint-bol) + (define-key inferior-scheme-mode-map "\C-c\C-a" 'beginning-of-line) + (define-key inferior-scheme-mode-map [C-c C-a] 'beginning-of-line) + (define-key inferior-scheme-mode-map "\r" 'guile-send-input) + (define-key inferior-scheme-mode-map "\t" 'guile-indent-or-complete) + (define-key inferior-scheme-mode-map "\M-?" 'guile-list-completions) + (define-key inferior-scheme-mode-map "\C-cd" 'guile-describe-variable) + (define-key inferior-scheme-mode-map [C-c d] 'guile-describe-variable) + + ;; Create the read-only overlay. + (make-local-variable 'inda-read-only-overlay) + (cond ((not (overlayp inda-read-only-overlay)) + (setq inda-read-only-overlay (make-overlay 1 (point))) + (overlay-put inda-read-only-overlay 'modification-hooks + '(inda-barf-at-modifications)))) + + ;; Disable font-lock + (make-local-variable 'font-lock-fontify-region-function) + (setq font-lock-fontify-region-function 'ignore) + + ;; We don't want all comint modes to have these values + (add-hook 'comint-input-filter-functions + (function inda-make-input-memory) 'append 'local) + (add-hook 'comint-input-filter-functions + (function inda-extend-read-only-overlay) 'append 'local) + (add-hook 'comint-output-filter-functions + (function inda-extend-read-only-overlay) 'append 'local) + (add-hook 'comint-output-filter-functions + (function inda-reset-guile-last-output) 'append 'local) + ;; This is a bit kludgy... + (add-hook 'scheme-enter-input-wait-hook (function inda-boldify-previous-character)) +) + +;; No message about reason when process dies + +(setq guile-insert-reason nil) + +(add-hook 'inferior-scheme-mode-hook + (function inda-inferior-initializations) + 'append) + +(require 'defmenu) + +;; Scheme mode menu +;; +(fset 'scheme-advanced-menu + (make-menu + "Advanced" + '( + ("Sync with scheme" guile-sync-with-scheme + (and (> guile-n-enhanced-buffers 0) + (not (guile-synchronizedp)) + scheme-ready-p)) + ("Re-eval buffer" guile-reread-buffer (and (guile-attachedp) + scheme-ready-p)) + () + ("Enhanced edit" guile-enhanced-edit (not (guile-enhancedp))) + ("Normal edit" guile-normal-edit (and (guile-enhancedp) + (not (guile-attachedp)))) + () + ("Eval definition" scheme-send-definition (comint-check-proc "*scheme*")) + ("Eval region" scheme-send-region (comint-check-proc "*scheme*")) + ("Eval buffer" scheme-send-buffer (comint-check-proc "*scheme*")) + ))) + +(define-menu scheme-mode-map 'scheme "Scheme" + '( + ("Eval definition" scheme-send-definition (comint-check-proc "*scheme*")) + ("Eval region" scheme-send-region (comint-check-proc "*scheme*")) + ("Eval buffer" scheme-send-buffer (comint-check-proc "*scheme*")) + ("Eval all changes" guile-send-changes (comint-check-proc "*scheme*")) + () + ("Indent buffer" indent-buffer) + ("Indent region" indent-region) + ("Indent definition" indent-defun) + () + ("Enhanced edit" guile-enhanced-edit (not (guile-enhancedp))) + ("Normal edit" guile-normal-edit (and (guile-enhancedp) + (not (guile-attachedp)))) + () + ("Attach buffer" guile-attach-buffer (and (comint-check-proc "*scheme*") + scheme-ready-p + (not (guile-attachedp)))) + ("Detach buffer" guile-detach-buffer (guile-attachedp)) + () + ("Re-init buffer" guile-reread-buffer (and (guile-attachedp) + scheme-ready-p)) + ("Find bad expressions" guile-check-all (> guile-n-enhanced-buffers 0)) + )) + +;(define-key scheme-mode-map [menu-bar interpret] 'undefined) + +;; Inferior scheme menu +;; +(define-menu inferior-scheme-mode-map 'scheme "Scheme" + '(("Start scheme" run-scheme (not (comint-check-proc "*scheme*"))) + ("Restart scheme" guile-restart-scheme (comint-check-proc "*scheme*")) + ("Exit scheme" guile-exit-scheme (comint-check-proc "*scheme*")) + () + ("Load file..." guile-load-file + (and (comint-check-proc "*scheme*") + scheme-ready-p)) + ("Eval all changes" guile-send-changes (comint-check-proc "*scheme*")) + ("Find bad expressions" guile-check-all (comint-check-proc "*scheme*")) + () + ("Clear transcript" guile-clear-transcript (comint-check-proc "*scheme*")))) + +(define-key inferior-scheme-mode-map [menu-bar interpret] 'undefined) hunk ./site-lisp/guileint-1.5/scheme.el 1 +;;; scheme.el --- Scheme (and DSSSL) editing mode + +;; Copyright (C) 1986, 87, 88, 97, 1998 Free Software Foundation, Inc. + +;; Author: Bill Rozas +;; Adapted-by: Dave Love +;; Keywords: languages, lisp + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs 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 General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; The major mode for editing Scheme-type Lisp code, very similar to +;; the Lisp mode documented in the Emacs manual. `dsssl-mode' is a +;; variant of scheme-mode for editing DSSSL specifications for SGML +;; documents. [As of Apr 1997, some pointers for DSSSL may be found, +;; for instance, at .] +;; All these Lisp-ish modes vary basically in details of the language +;; syntax they highlight/indent/index, but dsssl-mode uses "^;;;" as +;; the page-delimiter since ^L isn't normally a legal SGML character. +;; +;; For interacting with a Scheme interpreter See also `run-scheme' in +;; the `cmuscheme' package and also the implementation-specific +;; `xscheme' package. + +;; Here's a recipe to generate a TAGS file for DSSSL, by the way: +;; etags --lang=scheme --regex='/[ \t]*(\(mode\|element\)[ \t +;; ]+\([^ \t( +;; ]+\)/\2/' --regex='/[ \t]*(element[ \t +;; ]*([^)]+[ \t +;; ]+\([^)]+\)[ \t +;; ]*)/\1/' --regex='/(declare[^ \t +;; ]*[ \t +;; ]+\([^ \t +;; ]+\)/\1/' "$@" + +;;; Code: + +(require 'lisp-mode) + +(defvar scheme-mode-syntax-table nil) +(if (not scheme-mode-syntax-table) + (let ((i 0)) + (setq scheme-mode-syntax-table (make-syntax-table)) + (set-syntax-table scheme-mode-syntax-table) + + ;; Default is atom-constituent. + (while (< i 256) + (modify-syntax-entry i "_ ") + (setq i (1+ i))) + + ;; Word components. + (setq i ?0) + (while (<= i ?9) + (modify-syntax-entry i "w ") + (setq i (1+ i))) + (setq i ?A) + (while (<= i ?Z) + (modify-syntax-entry i "w ") + (setq i (1+ i))) + (setq i ?a) + (while (<= i ?z) + (modify-syntax-entry i "w ") + (setq i (1+ i))) + + ;; Whitespace + (modify-syntax-entry ?\t " ") + (modify-syntax-entry ?\n "> ") + (modify-syntax-entry ?\f " ") + (modify-syntax-entry ?\r " ") + (modify-syntax-entry ? " ") + + ;; These characters are delimiters but otherwise undefined. + ;; Brackets and braces balance for editing convenience. + (modify-syntax-entry ?\[ "(] ") + (modify-syntax-entry ?\] ")[ ") + (modify-syntax-entry ?{ "(} ") + (modify-syntax-entry ?} "){ ") + (modify-syntax-entry ?\| " 23") + + ;; Other atom delimiters + (modify-syntax-entry ?\( "() ") + (modify-syntax-entry ?\) ")( ") + (modify-syntax-entry ?\; "< ") + (modify-syntax-entry ?\" "\" ") + (modify-syntax-entry ?' " p") + (modify-syntax-entry ?` " p") + + ;; Special characters + (modify-syntax-entry ?, "_ p") + (modify-syntax-entry ?@ "_ p") + (modify-syntax-entry ?# "_ p14") + (modify-syntax-entry ?\\ "\\ "))) + +(defvar scheme-mode-abbrev-table nil) +(define-abbrev-table 'scheme-mode-abbrev-table ()) + +(defvar scheme-imenu-generic-expression + '((nil + "^(define\\(\\|-\\(generic\\(\\|-procedure\\)\\|method\\|\\*\\)\\)*\\s-+(?\\(\\sw+\\)" 4) + ("Types" + "^(define-class\\s-+(?\\(\\sw+\\)" 1) + ("Macros" + "^(\\(defmacro\\|define-macro\\|define-syntax\\)\\s-+(?\\(\\sw+\\)" 2)) + "Imenu generic expression for Scheme mode. See `imenu-generic-expression'.") + +(defun scheme-mode-variables () + (set-syntax-table scheme-mode-syntax-table) + (setq local-abbrev-table scheme-mode-abbrev-table) + (make-local-variable 'paragraph-start) + (setq paragraph-start (concat "$\\|" page-delimiter)) + (make-local-variable 'paragraph-separate) + (setq paragraph-separate paragraph-start) + (make-local-variable 'paragraph-ignore-fill-prefix) + (setq paragraph-ignore-fill-prefix t) + (make-local-variable 'fill-paragraph-function) + (setq fill-paragraph-function 'lisp-fill-paragraph) + ;; Adaptive fill mode gets in the way of auto-fill, + ;; and should make no difference for explicit fill + ;; because lisp-fill-paragraph should do the job. + (make-local-variable 'adaptive-fill-mode) + (setq adaptive-fill-mode nil) + (make-local-variable 'normal-auto-fill-function) + (setq normal-auto-fill-function 'lisp-mode-auto-fill) + (make-local-variable 'indent-line-function) + (setq indent-line-function 'lisp-indent-line) + (make-local-variable 'parse-sexp-ignore-comments) + (setq parse-sexp-ignore-comments t) + (make-local-variable 'outline-regexp) + (setq outline-regexp ";;; \\|(....") + (make-local-variable 'comment-start) + (setq comment-start ";") + (make-local-variable 'comment-start-skip) + ;; Look within the line for a ; following an even number of backslashes + ;; after either a non-backslash or the line beginning. + (setq comment-start-skip "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+[ \t]*") + (make-local-variable 'comment-column) + (setq comment-column 40) + (make-local-variable 'comment-indent-function) + (setq comment-indent-function 'lisp-comment-indent) + (make-local-variable 'parse-sexp-ignore-comments) + (setq parse-sexp-ignore-comments t) + (make-local-variable 'lisp-indent-function) + (set lisp-indent-function 'scheme-indent-function) + (make-local-variable 'scheme-mode-line-process) ;guileint added + (make-local-variable 'scheme-associated-process-buffer) ;guileint added + (setq mode-line-process '("" scheme-mode-line-process)) + (set (make-local-variable 'imenu-case-fold-search) t) + (setq imenu-generic-expression scheme-imenu-generic-expression) + (set (make-local-variable 'imenu-syntax-alist) + '(("+-*/.<>=?!$%_&~^:" . "w"))) + (make-local-variable 'font-lock-defaults) + (setq font-lock-defaults + '((scheme-font-lock-keywords + scheme-font-lock-keywords-1 scheme-font-lock-keywords-2) + nil t (("+-*/.<>=!?$%_&~^:" . "w")) beginning-of-defun + (font-lock-mark-block-function . mark-defun)))) + +(defvar scheme-mode-line-process "") + +(defvar scheme-associated-process-buffer nil) ;guileint added + +(defvar scheme-mode-map nil + "Keymap for Scheme mode. +All commands in `lisp-mode-shared-map' are inherited by this map.") + +(unless scheme-mode-map + (let ((map (make-sparse-keymap "Scheme"))) + (setq scheme-mode-map (make-sparse-keymap)) + (set-keymap-parent scheme-mode-map lisp-mode-shared-map) + (define-key scheme-mode-map [menu-bar] (make-sparse-keymap)) + (define-key scheme-mode-map [menu-bar scheme] + (cons "Scheme" map)) + (define-key map [run-scheme] '("Run Inferior Scheme" . run-scheme)) + (define-key map [uncomment-region] + '("Uncomment Out Region" . (lambda (beg end) + (interactive "r") + (comment-region beg end '(4))))) + (define-key map [comment-region] '("Comment Out Region" . comment-region)) + (define-key map [indent-region] '("Indent Region" . indent-region)) + (define-key map [indent-line] '("Indent Line" . lisp-indent-line)) + (put 'comment-region 'menu-enable 'mark-active) + (put 'uncomment-region 'menu-enable 'mark-active) + (put 'indent-region 'menu-enable 'mark-active))) + +;; Used by cmuscheme +(defun scheme-mode-commands (map) + ;;(define-key map "\t" 'indent-for-tab-command) ; default + (define-key map "\177" 'backward-delete-char-untabify) + (define-key map "\e\C-q" 'indent-sexp)) + +;;;###autoload +(defun scheme-mode () + "Major mode for editing Scheme code. +Editing commands are similar to those of `lisp-mode'. + +In addition, if an inferior Scheme process is running, some additional +commands will be defined, for evaluating expressions and controlling +the interpreter, and the state of the process will be displayed in the +modeline of all Scheme buffers. The names of commands that interact +with the Scheme process start with \"xscheme-\" if you use the MIT +Scheme-specific `xscheme' package; for more information see the +documentation for `xscheme-interaction-mode'. Use \\[run-scheme] to +start an inferior Scheme using the more general `cmuscheme' package. + +Commands: +Delete converts tabs to spaces as it moves back. +Blank lines separate paragraphs. Semicolons start comments. +\\{scheme-mode-map} +Entry to this mode calls the value of `scheme-mode-hook' +if that value is non-nil." + (interactive) + (kill-all-local-variables) + (scheme-mode-initialize) + (scheme-mode-variables) + (run-hooks 'scheme-mode-hook)) + +(defun scheme-mode-initialize () + (use-local-map scheme-mode-map) + (setq major-mode 'scheme-mode) + (setq mode-name "Scheme")) + +(defgroup scheme nil + "Editing Scheme code" + :group 'lisp) + +(defcustom scheme-mit-dialect t + "If non-nil, scheme mode is specialized for MIT Scheme. +Set this to nil if you normally use another dialect." + :type 'boolean + :group 'scheme) + +(defcustom dsssl-sgml-declaration + " +" + "*An SGML declaration for the DSSSL file. +If it is defined as a string this will be inserted into an empty buffer +which is in `dsssl-mode'. It is typically James Clark's style-sheet +doctype, as required for Jade." + :type '(choice (string :tag "Specified string") + (const :tag "None" :value nil)) + :group 'scheme) + +(defcustom scheme-mode-hook nil + "Normal hook run when entering `scheme-mode'. +See `run-hooks'." + :type 'hook + :group 'scheme) + +(defcustom dsssl-mode-hook nil + "Normal hook run when entering `dsssl-mode'. +See `run-hooks'." + :type 'hook + :group 'scheme) + +;; This is shared by cmuscheme and xscheme. +(defcustom scheme-program-name "scheme" + "*Program invoked by the `run-scheme' command." + :type 'string + :group 'scheme) + +(defvar dsssl-imenu-generic-expression + ;; Perhaps this should also look for the style-sheet DTD tags. I'm + ;; not sure it's the best way to organize it; perhaps one type + ;; should be at the first level, though you don't see this anyhow if + ;; it gets split up. + '(("Defines" + "^(define\\s-+(?\\(\\sw+\\)" 1) + ("Modes" + "^\\s-*(mode\\s-+\\(\\(\\sw\\|\\s-\\)+\\)" 1) + ("Elements" + ;; (element foo ...) or (element (foo bar ...) ...) + ;; Fixme: Perhaps it should do `root'. + "^\\s-*(element\\s-+(?\\(\\(\\sw\\|\\s-\\)+\\))?" 1) + ("Declarations" + "^(declare\\(-\\sw+\\)+\\>\\s-+\\(\\sw+\\)" 2)) + "Imenu generic expression for DSSSL mode. See `imenu-generic-expression'.") + +(defconst scheme-font-lock-keywords-1 + (eval-when-compile + (list + ;; + ;; Declarations. Hannes Haug says + ;; this works for SOS, STklos, SCOOPS, Meroon and Tiny CLOS. + (list (concat "(\\(define\\*?\\(" + ;; Function names. + "\\(\\|-public\\|-method\\|-generic\\|\\*\\(-procedure\\)?\\)\\|" + ;; Macro names, as variable names. A bit dubious, this. + "\\(-syntax\\|-macro\\)\\|" + ;; Class names. + "-class" + ;; Guile modules. + "\\|-module" + "\\)\\)\\>" + ;; Any whitespace and declared object. + "[ \t]*(?" + "\\(\\sw+\\)?") + '(1 font-lock-keyword-face) + '(6 (cond ((match-beginning 3) font-lock-function-name-face) + ((match-beginning 5) font-lock-variable-name-face) + (t font-lock-type-face)) + nil t)) + )) + "Subdued expressions to highlight in Scheme modes.") + +(defconst scheme-font-lock-keywords-2 + (append scheme-font-lock-keywords-1 + (eval-when-compile + (list + ;; + ;; Control structures. + (cons + (concat + "(" (regexp-opt + '("begin" "call-with-current-continuation" "call/cc" + "call-with-input-file" "call-with-output-file" "case" "cond" + "do" "else" "for-each" "if" "lambda" "lambda*" + "let" "let*" "let-syntax" "letrec" "letrec-syntax" + ;; Hannes Haug wants: + "and" "or" "delay" + ;; Stefan Monnier says don't bother: + ;;"quasiquote" "quote" "unquote" "unquote-splicing" + "map" "syntax" "syntax-rules" "use-modules" "define-module") t) + "\\>") 1) + ;; + ;; David Fox for SOS/STklos class specifiers. + '("\\<<\\sw+>\\>" . font-lock-type-face) + ;; + ;; Scheme `:' keywords as builtins. + '("\\<:\\sw+\\>" . font-lock-builtin-face) + ))) + "Gaudy expressions to highlight in Scheme modes.") + +(defvar scheme-font-lock-keywords scheme-font-lock-keywords-1 + "Default expressions to highlight in Scheme modes.") + +;;;###autoload +(defun dsssl-mode () + "Major mode for editing DSSSL code. +Editing commands are similar to those of `lisp-mode'. + +Commands: +Delete converts tabs to spaces as it moves back. +Blank lines separate paragraphs. Semicolons start comments. +\\{scheme-mode-map} +Entering this mode runs the hooks `scheme-mode-hook' and then +`dsssl-mode-hook' and inserts the value of `dsssl-sgml-declaration' if +that variable's value is a string." + (interactive) + (kill-all-local-variables) + (use-local-map scheme-mode-map) + (scheme-mode-initialize) + (make-local-variable 'page-delimiter) + (setq page-delimiter "^;;;" ; ^L not valid SGML char + major-mode 'dsssl-mode + mode-name "DSSSL") + ;; Insert a suitable SGML declaration into an empty buffer. + (and (zerop (buffer-size)) + (stringp dsssl-sgml-declaration) + (not buffer-read-only) + (insert dsssl-sgml-declaration)) + (scheme-mode-variables) + (setq font-lock-defaults '(dsssl-font-lock-keywords + nil t (("+-*/.<>=?$%_&~^:" . "w")) + beginning-of-defun + (font-lock-mark-block-function . mark-defun))) + (set (make-local-variable 'imenu-case-fold-search) nil) + (setq imenu-generic-expression dsssl-imenu-generic-expression) + (set (make-local-variable 'imenu-syntax-alist) + '(("+-*/.<>=?$%_&~^:" . "w"))) + (run-hooks 'scheme-mode-hook) + (run-hooks 'dsssl-mode-hook)) + +;; Extra syntax for DSSSL. This isn't separated from Scheme, but +;; shouldn't cause much trouble in scheme-mode. +(put 'element 'scheme-indent-function 1) +(put 'mode 'scheme-indent-function 1) +(put 'with-mode 'scheme-indent-function 1) +(put 'make 'scheme-indent-function 1) +(put 'style 'scheme-indent-function 1) +(put 'root 'scheme-indent-function 1) + +(defvar dsssl-font-lock-keywords + (eval-when-compile + (list + ;; Similar to Scheme + (list "(\\(define\\(-\\w+\\)?\\)\\>[ ]*\\\((?\\)\\(\\sw+\\)\\>" + '(1 font-lock-keyword-face) + '(4 font-lock-function-name-face)) + (cons + (concat "(\\(" + ;; (make-regexp '("case" "cond" "else" "if" "lambda" + ;; "let" "let*" "letrec" "and" "or" "map" "with-mode")) + "and\\|c\\(ase\\|ond\\)\\|else\\|if\\|" + "l\\(ambda\\|ambda\\*\\|et\\(\\|*\\|rec\\)\\)\\|map\\|or\\|with-mode" + "\\)\\>") + 1) + ;; DSSSL syntax + '("(\\(element\\|mode\\|declare-\\w+\\)\\>[ ]*\\(\\sw+\\)" + (1 font-lock-keyword-face) + (2 font-lock-type-face)) + '("(\\(element\\)\\>[ ]*(\\(\\S)+\\))" + (1 font-lock-keyword-face) + (2 font-lock-type-face)) + '("\\<\\sw+:\\>" . font-lock-constant-face) ; trailing `:' c.f. scheme + ;; SGML markup (from sgml-mode) : + '("<\\([!?][-a-z0-9]+\\)" 1 font-lock-keyword-face) + '("<\\(/?[-a-z0-9]+\\)" 1 font-lock-function-name-face))) + "Default expressions to highlight in DSSSL mode.") + + +(defvar calculate-lisp-indent-last-sexp) + +;; Copied from lisp-indent-function, but with gets of +;; scheme-indent-{function,hook}. +(defun scheme-indent-function (indent-point state) + (let ((normal-indent (current-column))) + (goto-char (1+ (elt state 1))) + (parse-partial-sexp (point) calculate-lisp-indent-last-sexp 0 t) + (if (and (elt state 2) + (not (looking-at "\\sw\\|\\s_"))) + ;; car of form doesn't seem to be a a symbol + (progn + (if (not (> (save-excursion (forward-line 1) (point)) + calculate-lisp-indent-last-sexp)) + (progn (goto-char calculate-lisp-indent-last-sexp) + (beginning-of-line) + (parse-partial-sexp (point) + calculate-lisp-indent-last-sexp 0 t))) + ;; Indent under the list or under the first sexp on the same + ;; line as calculate-lisp-indent-last-sexp. Note that first + ;; thing on that line has to be complete sexp since we are + ;; inside the innermost containing sexp. + (backward-prefix-chars) + (current-column)) + (let ((function (buffer-substring (point) + (progn (forward-sexp 1) (point)))) + method) + (setq method (or (get (intern-soft function) 'scheme-indent-function) + (get (intern-soft function) 'scheme-indent-hook))) + (cond ((or (eq method 'defun) + (and (null method) + (> (length function) 3) + (string-match "\\`def" function))) + (lisp-indent-defform state indent-point)) + ((integerp method) + (lisp-indent-specform method state + indent-point normal-indent)) + (method + (funcall method state indent-point normal-indent))))))) + + +;;; Let is different in Scheme + +(defun would-be-symbol (string) + (not (string-equal (substring string 0 1) "("))) + +(defun next-sexp-as-string () + ;; Assumes that it is protected by a save-excursion + (forward-sexp 1) + (let ((the-end (point))) + (backward-sexp 1) + (buffer-substring (point) the-end))) + +;; This is correct but too slow. +;; The one below works almost always. +;;(defun scheme-let-indent (state indent-point) +;; (if (would-be-symbol (next-sexp-as-string)) +;; (scheme-indent-specform 2 state indent-point) +;; (scheme-indent-specform 1 state indent-point))) + +(defun scheme-let-indent (state indent-point normal-indent) + (skip-chars-forward " \t") + (if (looking-at "[-a-zA-Z0-9+*/?!@$%^&_:~]") + (lisp-indent-specform 2 state indent-point normal-indent) + (lisp-indent-specform 1 state indent-point normal-indent))) + +;; (put 'begin 'scheme-indent-function 0), say, causes begin to be indented +;; like defun if the first form is placed on the next line, otherwise +;; it is indented like any other form (i.e. forms line up under first). + +(put 'begin 'scheme-indent-function 0) +(put 'case 'scheme-indent-function 1) +(put 'delay 'scheme-indent-function 0) +(put 'do 'scheme-indent-function 2) +(put 'lambda 'scheme-indent-function 1) +(put 'let 'scheme-indent-function 'scheme-let-indent) +(put 'let* 'scheme-indent-function 1) +(put 'letrec 'scheme-indent-function 1) +(put 'sequence 'scheme-indent-function 0) ; SICP, not r4rs +(put 'let-syntax 'scheme-indent-function 1) +(put 'letrec-syntax 'scheme-indent-function 1) +(put 'syntax-rules 'scheme-indent-function 1) + + +(put 'call-with-input-file 'scheme-indent-function 1) +(put 'with-input-from-file 'scheme-indent-function 1) +(put 'with-input-from-port 'scheme-indent-function 1) +(put 'call-with-output-file 'scheme-indent-function 1) +(put 'with-output-to-file 'scheme-indent-function 1) +(put 'with-output-to-port 'scheme-indent-function 1) +(put 'call-with-values 'scheme-indent-function 1) ; r5rs? +(put 'dynamic-wind 'scheme-indent-function 3) ; r5rs? + +;;;; MIT Scheme specific indentation. + +(if scheme-mit-dialect + (progn + (put 'fluid-let 'scheme-indent-function 1) + (put 'in-package 'scheme-indent-function 1) + (put 'local-declare 'scheme-indent-function 1) + (put 'macro 'scheme-indent-function 1) + (put 'make-environment 'scheme-indent-function 0) + (put 'named-lambda 'scheme-indent-function 1) + (put 'using-syntax 'scheme-indent-function 1) + + (put 'with-input-from-string 'scheme-indent-function 1) + (put 'with-output-to-string 'scheme-indent-function 0) + (put 'with-values 'scheme-indent-function 1) + + (put 'syntax-table-define 'scheme-indent-function 2) + (put 'list-transform-positive 'scheme-indent-function 1) + (put 'list-transform-negative 'scheme-indent-function 1) + (put 'list-search-positive 'scheme-indent-function 1) + (put 'list-search-negative 'scheme-indent-function 1) + + (put 'access-components 'scheme-indent-function 1) + (put 'assignment-components 'scheme-indent-function 1) + (put 'combination-components 'scheme-indent-function 1) + (put 'comment-components 'scheme-indent-function 1) + (put 'conditional-components 'scheme-indent-function 1) + (put 'disjunction-components 'scheme-indent-function 1) + (put 'declaration-components 'scheme-indent-function 1) + (put 'definition-components 'scheme-indent-function 1) + (put 'delay-components 'scheme-indent-function 1) + (put 'in-package-components 'scheme-indent-function 1) + (put 'lambda-components 'scheme-indent-function 1) + (put 'lambda-components* 'scheme-indent-function 1) + (put 'lambda-components** 'scheme-indent-function 1) + (put 'open-block-components 'scheme-indent-function 1) + (put 'pathname-components 'scheme-indent-function 1) + (put 'procedure-components 'scheme-indent-function 1) + (put 'sequence-components 'scheme-indent-function 1) + (put 'unassigned\?-components 'scheme-indent-function 1) + (put 'unbound\?-components 'scheme-indent-function 1) + (put 'variable-components 'scheme-indent-function 1))) + +(provide 'scheme) + +;;; scheme.el ends here hunk ./site-lisp/guileint-1.5/xscheme.el 1 +;;; xscheme.el --- run Scheme under Emacs + +;; Copyright (C) 1986, 1987, 1989, 1990 Free Software Foundation, Inc. + +;; Maintainer: FSF +;; Keywords: languages, lisp + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs 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 General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Commentary: + +;; A major mode for editing Scheme and interacting with MIT's C-Scheme. +;; +;; Requires C-Scheme release 5 or later +;; Changes to Control-G handler require runtime version 13.85 or later + +;;; Code: + +(require 'scheme) + +(defvar scheme-program-name "scheme" + "*Program invoked by the `run-scheme' command.") + +(defvar scheme-band-name nil + "*Band loaded by the `run-scheme' command.") + +(defvar scheme-program-arguments nil + "*Arguments passed to the Scheme program by the `run-scheme' command.") + +(defvar xscheme-allow-pipelined-evaluation t + "If non-nil, an expression may be transmitted while another is evaluating. +Otherwise, attempting to evaluate an expression before the previous expression +has finished evaluating will signal an error.") + +(defvar xscheme-startup-message + "This is the Scheme process buffer. +Type \\[advertised-xscheme-send-previous-expression] to evaluate the expression before point. +Type \\[xscheme-send-control-g-interrupt] to abort evaluation. +Type \\[describe-mode] for more information. + +" + "String to insert into Scheme process buffer first time it is started. +Is processed with `substitute-command-keys' first.") + +(defvar xscheme-signal-death-message nil + "If non-nil, causes a message to be generated when the Scheme process dies.") + +(defun xscheme-evaluation-commands (keymap) + (define-key keymap "\e\C-x" 'xscheme-send-definition) + (define-key keymap "\C-x\C-e" 'advertised-xscheme-send-previous-expression) + (define-key keymap "\eo" 'xscheme-send-buffer) + (define-key keymap "\ez" 'xscheme-send-definition) + (define-key keymap "\e\C-m" 'xscheme-send-previous-expression) + (define-key keymap "\e\C-z" 'xscheme-send-region)) + +(defun xscheme-interrupt-commands (keymap) + (define-key keymap "\C-c\C-s" 'xscheme-select-process-buffer) + (define-key keymap "\C-c\C-b" 'xscheme-send-breakpoint-interrupt) + (define-key keymap "\C-c\C-c" 'xscheme-send-control-g-interrupt) + (define-key keymap "\C-c\C-u" 'xscheme-send-control-u-interrupt) + (define-key keymap "\C-c\C-x" 'xscheme-send-control-x-interrupt)) + +(xscheme-evaluation-commands scheme-mode-map) +(xscheme-interrupt-commands scheme-mode-map) + +(defun run-scheme (command-line) + "Run MIT Scheme in an inferior process. +Output goes to the buffer `*scheme*'. +With argument, asks for a command line." + (interactive + (list (let ((default + (or xscheme-process-command-line + (xscheme-default-command-line)))) + (if current-prefix-arg + (read-string "Run Scheme: " default) + default)))) + (setq xscheme-process-command-line command-line) + (switch-to-buffer (xscheme-start-process command-line))) + +(defun reset-scheme () + "Reset the Scheme process." + (interactive) + (let ((process (get-process "scheme"))) + (cond ((or (not process) + (not (eq (process-status process) 'run)) + (yes-or-no-p +"The Scheme process is running, are you SURE you want to reset it? ")) + (message "Resetting Scheme process...") + (if process (kill-process process t)) + (xscheme-start-process xscheme-process-command-line) + (message "Resetting Scheme process...done"))))) + +(defun xscheme-default-command-line () + (concat scheme-program-name " -emacs" + (if scheme-program-arguments + (concat " " scheme-program-arguments) + "") + (if scheme-band-name + (concat " -band " scheme-band-name) + ""))) + +;;;; Interaction Mode + +(defun scheme-interaction-mode () + "Major mode for interacting with the inferior Scheme process. +Like scheme-mode except that: + +\\[advertised-xscheme-send-previous-expression] sends the expression before point to the Scheme process as input +\\[xscheme-yank-previous-send] yanks the expression most recently sent to Scheme + +All output from the Scheme process is written in the Scheme process +buffer, which is initially named \"*scheme*\". The result of +evaluating a Scheme expression is also printed in the process buffer, +preceded by the string \";Value: \" to highlight it. If the process +buffer is not visible at that time, the value will also be displayed +in the minibuffer. If an error occurs, the process buffer will +automatically pop up to show you the error message. + +While the Scheme process is running, the modelines of all buffers in +scheme-mode are modified to show the state of the process. The +possible states and their meanings are: + +input waiting for input +run evaluating +gc garbage collecting + +The process buffer's modeline contains additional information where +the buffer's name is normally displayed: the command interpreter level +and type. + +Scheme maintains a stack of command interpreters. Every time an error +or breakpoint occurs, the current command interpreter is pushed on the +command interpreter stack, and a new command interpreter is started. +One example of why this is done is so that an error that occurs while +you are debugging another error will not destroy the state of the +initial error, allowing you to return to it after the second error has +been fixed. + +The command interpreter level indicates how many interpreters are in +the command interpreter stack. It is initially set to one, and it is +incremented every time that stack is pushed, and decremented every +time it is popped. The following commands are useful for manipulating +the command interpreter stack: + +\\[xscheme-send-breakpoint-interrupt] pushes the stack once +\\[xscheme-send-control-u-interrupt] pops the stack once +\\[xscheme-send-control-g-interrupt] pops everything off +\\[xscheme-send-control-x-interrupt] aborts evaluation, doesn't affect stack + +Some possible command interpreter types and their meanings are: + +[Evaluator] read-eval-print loop for evaluating expressions +[Debugger] single character commands for debugging errors +[Where] single character commands for examining environments + +Starting with release 6.2 of Scheme, the latter two types of command +interpreters will change the major mode of the Scheme process buffer +to scheme-debugger-mode , in which the evaluation commands are +disabled, and the keys which normally self insert instead send +themselves to the Scheme process. The command character ? will list +the available commands. + +For older releases of Scheme, the major mode will be be +scheme-interaction-mode , and the command characters must be sent as +if they were expressions. + +Commands: +Delete converts tabs to spaces as it moves back. +Blank lines separate paragraphs. Semicolons start comments. +\\{scheme-interaction-mode-map} + +Entry to this mode calls the value of scheme-interaction-mode-hook +with no args, if that value is non-nil. + Likewise with the value of scheme-mode-hook. + scheme-interaction-mode-hook is called after scheme-mode-hook." + (interactive) + (kill-all-local-variables) + (scheme-interaction-mode-initialize) + (scheme-mode-variables) + (make-local-variable 'xscheme-previous-send) + (run-hooks 'scheme-mode-hook 'scheme-interaction-mode-hook)) + +(defun scheme-interaction-mode-initialize () + (use-local-map scheme-interaction-mode-map) + (setq major-mode 'scheme-interaction-mode) + (setq mode-name "Scheme Interaction")) + +(defun scheme-interaction-mode-commands (keymap) + (define-key keymap "\C-c\C-m" 'xscheme-send-current-line) + (define-key keymap "\C-c\C-p" 'xscheme-send-proceed) + (define-key keymap "\C-c\C-y" 'xscheme-yank-previous-send)) + +(defvar scheme-interaction-mode-map nil) +(if (not scheme-interaction-mode-map) + (progn + (setq scheme-interaction-mode-map (make-keymap)) + (scheme-mode-commands scheme-interaction-mode-map) + (xscheme-interrupt-commands scheme-interaction-mode-map) + (xscheme-evaluation-commands scheme-interaction-mode-map) + (scheme-interaction-mode-commands scheme-interaction-mode-map))) + +(defun xscheme-enter-interaction-mode () + (save-excursion + (set-buffer (xscheme-process-buffer)) + (if (not (eq major-mode 'scheme-interaction-mode)) + (if (eq major-mode 'scheme-debugger-mode) + (scheme-interaction-mode-initialize) + (scheme-interaction-mode))))) + +(fset 'advertised-xscheme-send-previous-expression + 'xscheme-send-previous-expression) + +;;;; Debugger Mode + +(defun scheme-debugger-mode () + "Major mode for executing the Scheme debugger. +Like scheme-mode except that the evaluation commands +are disabled, and characters that would normally be self inserting are +sent to the Scheme process instead. Typing ? will show you which +characters perform useful functions. + +Commands: +\\{scheme-debugger-mode-map}" + (error "Illegal entry to scheme-debugger-mode")) + +(defun scheme-debugger-mode-initialize () + (use-local-map scheme-debugger-mode-map) + (setq major-mode 'scheme-debugger-mode) + (setq mode-name "Scheme Debugger")) + +(defun scheme-debugger-mode-commands (keymap) + (let ((char ? )) + (while (< char 127) + (define-key keymap (char-to-string char) 'scheme-debugger-self-insert) + (setq char (1+ char))))) + +(defvar scheme-debugger-mode-map nil) +(if (not scheme-debugger-mode-map) + (progn + (setq scheme-debugger-mode-map (make-keymap)) + (scheme-mode-commands scheme-debugger-mode-map) + (xscheme-interrupt-commands scheme-debugger-mode-map) + (scheme-debugger-mode-commands scheme-debugger-mode-map))) + +(defun scheme-debugger-self-insert () + "Transmit this character to the Scheme process." + (interactive) + (xscheme-send-char last-command-char)) + +(defun xscheme-enter-debugger-mode (prompt-string) + (save-excursion + (set-buffer (xscheme-process-buffer)) + (if (not (eq major-mode 'scheme-debugger-mode)) + (progn + (if (not (eq major-mode 'scheme-interaction-mode)) + (scheme-interaction-mode)) + (scheme-debugger-mode-initialize))))) + +(defun xscheme-debugger-mode-p () + (let ((buffer (xscheme-process-buffer))) + (and buffer + (save-excursion + (set-buffer buffer) + (eq major-mode 'scheme-debugger-mode))))) + +;;;; Evaluation Commands + +(defun xscheme-send-string (&rest strings) + "Send the string arguments to the Scheme process. +The strings are concatenated and terminated by a newline." + (cond ((not (xscheme-process-running-p)) + (if (yes-or-no-p "The Scheme process has died. Reset it? ") + (progn + (reset-scheme) + (xscheme-wait-for-process) + (goto-char (point-max)) + (apply 'insert-before-markers strings) + (xscheme-send-string-1 strings)))) + ((xscheme-debugger-mode-p) (error "No sends allowed in debugger mode")) + ((and (not xscheme-allow-pipelined-evaluation) + xscheme-running-p) + (error "No sends allowed while Scheme running")) + (t (xscheme-send-string-1 strings)))) + +(defun xscheme-send-string-1 (strings) + (let ((string (apply 'concat strings))) + (xscheme-send-string-2 string) + (if (eq major-mode 'scheme-interaction-mode) + (setq xscheme-previous-send string)))) + +(defun xscheme-send-string-2 (string) + (let ((process (get-process "scheme"))) + (send-string process (concat string "\n")) + (if (xscheme-process-buffer-current-p) + (set-marker (process-mark process) (point))))) + +(defun xscheme-yank-previous-send () + "Insert the most recent expression at point." + (interactive) + (push-mark) + (insert xscheme-previous-send)) + +(defun xscheme-select-process-buffer () + "Select the Scheme process buffer and move to its output point." + (interactive) + (let ((process (or (get-process "scheme") (error "No scheme process")))) + (let ((buffer (or (process-buffer process) (error "No process buffer")))) + (let ((window (get-buffer-window buffer))) + (if window + (select-window window) + (switch-to-buffer buffer)) + (goto-char (process-mark process)))))) + +(defun xscheme-send-region (start end) + "Send the current region to the Scheme process. +The region is sent terminated by a newline." + (interactive "r") + (if (xscheme-process-buffer-current-p) + (progn (goto-char end) + (set-marker (process-mark (get-process "scheme")) end))) + (xscheme-send-string (buffer-substring start end))) + +(defun xscheme-send-definition () + "Send the current definition to the Scheme process. +If the current line begins with a non-whitespace character, +parse an expression from the beginning of the line and send that instead." + (interactive) + (let ((start nil) (end nil)) + (save-excursion + (end-of-defun) + (setq end (point)) + (if (re-search-backward "^\\s(" nil t) + (setq start (point)) + (error "Can't find definition"))) + (xscheme-send-region start end))) + +(defun xscheme-send-next-expression () + "Send the expression to the right of `point' to the Scheme process." + (interactive) + (let ((start (point))) + (xscheme-send-region start (save-excursion (forward-sexp) (point))))) + +(defun xscheme-send-previous-expression () + "Send the expression to the left of `point' to the Scheme process." + (interactive) + (let ((end (point))) + (xscheme-send-region (save-excursion (backward-sexp) (point)) end))) + +(defun xscheme-send-current-line () + "Send the current line to the Scheme process. +Useful for working with debugging Scheme under adb." + (interactive) + (let ((line + (save-excursion + (beginning-of-line) + (let ((start (point))) + (end-of-line) + (buffer-substring start (point)))))) + (end-of-line) + (insert ?\n) + (xscheme-send-string-2 line))) + +(defun xscheme-send-buffer () + "Send the current buffer to the Scheme process." + (interactive) + (if (xscheme-process-buffer-current-p) + (error "Not allowed to send this buffer's contents to Scheme")) + (xscheme-send-region (point-min) (point-max))) + +(defun xscheme-send-char (char) + "Prompt for a character and send it to the Scheme process." + (interactive "cCharacter to send: ") + (send-string "scheme" (char-to-string char))) + +;;;; Interrupts + +(defun xscheme-send-breakpoint-interrupt () + "Cause the Scheme process to enter a breakpoint." + (interactive) + (xscheme-send-interrupt ?b nil)) + +(defun xscheme-send-proceed () + "Cause the Scheme process to proceed from a breakpoint." + (interactive) + (send-string "scheme" "(proceed)\n")) + +(defun xscheme-send-control-g-interrupt () + "Cause the Scheme processor to halt and flush input. +Control returns to the top level rep loop." + (interactive) + (let ((inhibit-quit t)) + (cond ((not xscheme-control-g-synchronization-p) + (interrupt-process "scheme")) + (xscheme-control-g-disabled-p + (message "Relax...")) + (t + (setq xscheme-control-g-disabled-p t) + (message "Sending C-G interrupt to Scheme...") + (interrupt-process "scheme") + (send-string "scheme" (char-to-string 0)))))) + +(defun xscheme-send-control-u-interrupt () + "Cause the Scheme process to halt, returning to previous rep loop." + (interactive) + (xscheme-send-interrupt ?u t)) + +(defun xscheme-send-control-x-interrupt () + "Cause the Scheme process to halt, returning to current rep loop." + (interactive) + (xscheme-send-interrupt ?x t)) + +;;; This doesn't really work right -- Scheme just gobbles the first +;;; character in the input. There is no way for us to guarantee that +;;; the argument to this procedure is the first char unless we put +;;; some kind of marker in the input stream. + +(defun xscheme-send-interrupt (char mark-p) + "Send a ^A type interrupt to the Scheme process." + (interactive "cInterrupt character to send: ") + (quit-process "scheme") + (send-string "scheme" (char-to-string char)) + (if (and mark-p xscheme-control-g-synchronization-p) + (send-string "scheme" (char-to-string 0)))) + +;;;; Internal Variables + +(defvar xscheme-process-command-line nil + "Command used to start the most recent Scheme process.") + +(defvar xscheme-previous-send "" + "Most recent expression transmitted to the Scheme process.") + +(defvar xscheme-process-filter-state 'idle + "State of scheme process escape reader state machine: +idle waiting for an escape sequence +reading-type received an altmode but nothing else +reading-string reading prompt string") + +(defvar xscheme-running-p nil + "This variable, if nil, indicates that the scheme process is +waiting for input. Otherwise, it is busy evaluating something.") + +(defconst xscheme-control-g-synchronization-p t + "If non-nil, insert markers in the scheme input stream to indicate when +control-g interrupts were signalled. Do not allow more control-g's to be +signalled until the scheme process acknowledges receipt.") + +(defvar xscheme-control-g-disabled-p nil + "This variable, if non-nil, indicates that a control-g is being processed +by the scheme process, so additional control-g's are to be ignored.") + +(defvar xscheme-allow-output-p t + "This variable, if nil, prevents output from the scheme process +from being inserted into the process-buffer.") + +(defvar xscheme-prompt "" + "The current scheme prompt string.") + +(defvar xscheme-string-accumulator "" + "Accumulator for the string being received from the scheme process.") + +(defvar xscheme-string-receiver nil + "Procedure to send the string argument from the scheme process.") + +(defvar xscheme-start-hook nil + "If non-nil, a procedure to call when the Scheme process is started. +When called, the current buffer will be the Scheme process-buffer.") + +(defvar xscheme-runlight-string nil) +(defvar xscheme-mode-string nil) +(defvar xscheme-filter-input nil) + +;;;; Basic Process Control + +(defun xscheme-start-process (command-line) + (let ((buffer (get-buffer-create "*scheme*"))) + (let ((process (get-buffer-process buffer))) + (save-excursion + (set-buffer buffer) + (if (and process (memq (process-status process) '(run stop))) + (set-marker (process-mark process) (point-max)) + (progn (if process (delete-process process)) + (goto-char (point-max)) + (scheme-interaction-mode) + (if (bobp) + (insert-before-markers + (substitute-command-keys xscheme-startup-message))) + (setq process + (let ((process-connection-type nil)) + (apply 'start-process + (cons "scheme" + (cons buffer + (xscheme-parse-command-line + command-line)))))) + (set-marker (process-mark process) (point-max)) + (xscheme-process-filter-initialize t) + (xscheme-modeline-initialize) + (set-process-sentinel process 'xscheme-process-sentinel) + (set-process-filter process 'xscheme-process-filter) + (run-hooks 'xscheme-start-hook))))) + buffer)) + +(defun xscheme-parse-command-line (string) + (setq string (substitute-in-file-name string)) + (let ((start 0) + (result '())) + (while start + (let ((index (string-match "[ \t]" string start))) + (setq start + (cond ((not index) + (setq result + (cons (substring string start) + result)) + nil) + ((= index start) + (string-match "[^ \t]" string start)) + (t + (setq result + (cons (substring string start index) + result)) + (1+ index)))))) + (nreverse result))) + +(defun xscheme-wait-for-process () + (sleep-for 2) + (while xscheme-running-p + (sleep-for 1))) + +(defun xscheme-process-running-p () + "True iff there is a Scheme process whose status is `run'." + (let ((process (get-process "scheme"))) + (and process + (eq (process-status process) 'run)))) + +(defun xscheme-process-buffer () + (let ((process (get-process "scheme"))) + (and process (process-buffer process)))) + +(defun xscheme-process-buffer-window () + (let ((buffer (xscheme-process-buffer))) + (and buffer (get-buffer-window buffer)))) + +(defun xscheme-process-buffer-current-p () + "True iff the current buffer is the Scheme process buffer." + (eq (xscheme-process-buffer) (current-buffer))) + +;;;; Process Filter + +(defun xscheme-process-sentinel (proc reason) + (xscheme-process-filter-initialize (eq reason 'run)) + (if (eq reason 'run) + (xscheme-modeline-initialize) + (progn + (setq scheme-mode-line-process "") + (setq xscheme-mode-string "no process"))) + (if (and (not (memq reason '(run stop))) + xscheme-signal-death-message) + (progn (beep) + (message +"The Scheme process has died! Do M-x reset-scheme to restart it")))) + +(defun xscheme-process-filter-initialize (running-p) + (setq xscheme-process-filter-state 'idle) + (setq xscheme-running-p running-p) + (setq xscheme-control-g-disabled-p nil) + (setq xscheme-allow-output-p t) + (setq xscheme-prompt "") + (setq scheme-mode-line-process '(": " xscheme-runlight-string))) + +(defun xscheme-process-filter (proc string) + (let ((xscheme-filter-input string)) + (while xscheme-filter-input + (cond ((eq xscheme-process-filter-state 'idle) + (let ((start (string-match "\e" xscheme-filter-input))) + (if start + (progn + (xscheme-process-filter-output + (substring xscheme-filter-input 0 start)) + (setq xscheme-filter-input + (substring xscheme-filter-input (1+ start))) + (setq xscheme-process-filter-state 'reading-type)) + (let ((string xscheme-filter-input)) + (setq xscheme-filter-input nil) + (xscheme-process-filter-output string))))) + ((eq xscheme-process-filter-state 'reading-type) + (if (zerop (length xscheme-filter-input)) + (setq xscheme-filter-input nil) + (let ((char (aref xscheme-filter-input 0))) + (setq xscheme-filter-input + (substring xscheme-filter-input 1)) + (let ((entry (assoc char xscheme-process-filter-alist))) + (if entry + (funcall (nth 2 entry) (nth 1 entry)) + (progn + (xscheme-process-filter-output ?\e char) + (setq xscheme-process-filter-state 'idle))))))) + ((eq xscheme-process-filter-state 'reading-string) + (let ((start (string-match "\e" xscheme-filter-input))) + (if start + (let ((string + (concat xscheme-string-accumulator + (substring xscheme-filter-input 0 start)))) + (setq xscheme-filter-input + (substring xscheme-filter-input (1+ start))) + (setq xscheme-process-filter-state 'idle) + (funcall xscheme-string-receiver string)) + (progn + (setq xscheme-string-accumulator + (concat xscheme-string-accumulator + xscheme-filter-input)) + (setq xscheme-filter-input nil))))) + (t + (error "Scheme process filter -- bad state")))))) + +;;;; Process Filter Output + +(defun xscheme-process-filter-output (&rest args) + (if xscheme-allow-output-p + (let ((string (apply 'concat args))) + (save-excursion + (xscheme-goto-output-point) + (while (string-match "\\(\007\\|\f\\)" string) + (let ((start (match-beginning 0)) + (end (match-end 0))) + (insert-before-markers (substring string 0 start)) + (if (= ?\f (aref string start)) + (progn + (if (not (bolp)) + (insert-before-markers ?\n)) + (insert-before-markers ?\f)) + (beep)) + (setq string (substring string (1+ start))))) + (insert-before-markers string))))) + +(defun xscheme-guarantee-newlines (n) + (if xscheme-allow-output-p + (save-excursion + (xscheme-goto-output-point) + (let ((stop nil)) + (while (and (not stop) + (bolp)) + (setq n (1- n)) + (if (bobp) + (setq stop t) + (backward-char)))) + (xscheme-goto-output-point) + (while (> n 0) + (insert-before-markers ?\n) + (setq n (1- n)))))) + +(defun xscheme-goto-output-point () + (let ((process (get-process "scheme"))) + (set-buffer (process-buffer process)) + (goto-char (process-mark process)))) + +(defun xscheme-modeline-initialize () + (setq xscheme-runlight-string "") + (setq xscheme-mode-string "") + (setq mode-line-buffer-identification '("Scheme: " xscheme-mode-string))) + +(defun xscheme-set-runlight (runlight) + (setq xscheme-runlight-string runlight) + (force-mode-line-update t)) + +;;;; Process Filter Operations + +(defvar xscheme-process-filter-alist + '((?D xscheme-enter-debugger-mode + xscheme-process-filter:string-action) + (?E xscheme-eval + xscheme-process-filter:string-action) + (?P xscheme-set-prompt-variable + xscheme-process-filter:string-action) + (?R xscheme-enter-interaction-mode + xscheme-process-filter:simple-action) + (?b xscheme-start-gc + xscheme-process-filter:simple-action) + (?e xscheme-finish-gc + xscheme-process-filter:simple-action) + (?f xscheme-exit-input-wait + xscheme-process-filter:simple-action) + (?g xscheme-enable-control-g + xscheme-process-filter:simple-action) + (?i xscheme-prompt-for-expression + xscheme-process-filter:string-action) + (?m xscheme-message + xscheme-process-filter:string-action) + (?n xscheme-prompt-for-confirmation + xscheme-process-filter:string-action) + (?o xscheme-output-goto + xscheme-process-filter:simple-action) + (?p xscheme-set-prompt + xscheme-process-filter:string-action) + (?s xscheme-enter-input-wait + xscheme-process-filter:simple-action) + (?v xscheme-write-value + xscheme-process-filter:string-action) + (?w xscheme-cd + xscheme-process-filter:string-action) + (?z xscheme-display-process-buffer + xscheme-process-filter:simple-action) + (?c xscheme-unsolicited-read-char + xscheme-process-filter:simple-action)) + "Table used to decide how to handle process filter commands. +Value is a list of entries, each entry is a list of three items. + +The first item is the character that the process filter dispatches on. +The second item is the action to be taken, a function. +The third item is the handler for the entry, a function. + +When the process filter sees a command whose character matches a +particular entry, it calls the handler with two arguments: the action +and the string containing the rest of the process filter's input +stream. It is the responsibility of the handler to invoke the action +with the appropriate arguments, and to reenter the process filter with +the remaining input.") + +(defun xscheme-process-filter:simple-action (action) + (setq xscheme-process-filter-state 'idle) + (funcall action)) + +(defun xscheme-process-filter:string-action (action) + (setq xscheme-string-receiver action) + (setq xscheme-string-accumulator "") + (setq xscheme-process-filter-state 'reading-string)) + +(defconst xscheme-runlight:running "run" + "The character displayed when the Scheme process is running.") + +(defconst xscheme-runlight:input "input" + "The character displayed when the Scheme process is waiting for input.") + +(defconst xscheme-runlight:gc "gc" + "The character displayed when the Scheme process is garbage collecting.") + +(defun xscheme-start-gc () + (xscheme-set-runlight xscheme-runlight:gc)) + +(defun xscheme-finish-gc () + (xscheme-set-runlight + (if xscheme-running-p xscheme-runlight:running xscheme-runlight:input))) + +(defun xscheme-enter-input-wait () + (xscheme-set-runlight xscheme-runlight:input) + (setq xscheme-running-p nil)) + +(defun xscheme-exit-input-wait () + (xscheme-set-runlight xscheme-runlight:running) + (setq xscheme-running-p t)) + +(defun xscheme-enable-control-g () + (setq xscheme-control-g-disabled-p nil)) + +(defun xscheme-display-process-buffer () + (let ((window (or (xscheme-process-buffer-window) + (display-buffer (xscheme-process-buffer))))) + (save-window-excursion + (select-window window) + (xscheme-goto-output-point) + (if (xscheme-debugger-mode-p) + (xscheme-enter-interaction-mode))))) + +(defun xscheme-unsolicited-read-char () + nil) + +(defun xscheme-eval (string) + (eval (car (read-from-string string)))) + +(defun xscheme-message (string) + (if (not (zerop (length string))) + (xscheme-write-message-1 string (format ";%s" string)))) + +(defun xscheme-write-value (string) + (if (zerop (length string)) + (xscheme-write-message-1 "(no value)" ";No value") + (xscheme-write-message-1 string (format ";Value: %s" string)))) + +(defun xscheme-write-message-1 (message-string output-string) + (let* ((process (get-process "scheme")) + (window (get-buffer-window (process-buffer process)))) + (if (or (not window) + (not (pos-visible-in-window-p (process-mark process) + window))) + (message "%s" message-string))) + (xscheme-guarantee-newlines 1) + (xscheme-process-filter-output output-string)) + +(defun xscheme-set-prompt-variable (string) + (setq xscheme-prompt string)) + +(defun xscheme-set-prompt (string) + (setq xscheme-prompt string) + (xscheme-guarantee-newlines 2) + (setq xscheme-mode-string (xscheme-coerce-prompt string)) + (force-mode-line-update t)) + +(defun xscheme-output-goto () + (xscheme-goto-output-point) + (xscheme-guarantee-newlines 2)) + +(defun xscheme-coerce-prompt (string) + (if (string-match "^[0-9]+ " string) + (let ((end (match-end 0))) + (concat (substring string 0 end) + (let ((prompt (substring string end))) + (let ((entry (assoc prompt xscheme-prompt-alist))) + (if entry + (cdr entry) + prompt))))) + string)) + +(defvar xscheme-prompt-alist + '(("[Normal REPL]" . "[Evaluator]") + ("[Error REPL]" . "[Evaluator]") + ("[Breakpoint REPL]" . "[Evaluator]") + ("[Debugger REPL]" . "[Evaluator]") + ("[Visiting environment]" . "[Evaluator]") + ("[Environment Inspector]" . "[Where]")) + "An alist which maps the Scheme command interpreter type to a print string.") + +(defun xscheme-cd (directory-string) + (save-excursion + (set-buffer (xscheme-process-buffer)) + (cd directory-string))) + +(defun xscheme-prompt-for-confirmation (prompt-string) + (xscheme-send-char (if (y-or-n-p prompt-string) ?y ?n))) + +(defun xscheme-prompt-for-expression (prompt-string) + (xscheme-send-string-2 + (read-from-minibuffer prompt-string nil xscheme-prompt-for-expression-map))) + +(defvar xscheme-prompt-for-expression-map nil) +(if (not xscheme-prompt-for-expression-map) + (progn + (setq xscheme-prompt-for-expression-map + (copy-keymap minibuffer-local-map)) + (substitute-key-definition 'exit-minibuffer + 'xscheme-prompt-for-expression-exit + xscheme-prompt-for-expression-map))) + +(defun xscheme-prompt-for-expression-exit () + (interactive) + (if (eq (xscheme-region-expression-p (point-min) (point-max)) 'one) + (exit-minibuffer) + (error "input must be a single, complete expression"))) + +(defun xscheme-region-expression-p (start end) + (save-excursion + (let ((old-syntax-table (syntax-table))) + (unwind-protect + (progn + (set-syntax-table scheme-mode-syntax-table) + (let ((state (parse-partial-sexp start end))) + (and (zerop (car state)) ;depth = 0 + (nth 2 state) ;last-sexp exists, i.e. >= 1 sexps + (let ((state (parse-partial-sexp start (nth 2 state)))) + (if (nth 2 state) 'many 'one))))) + (set-syntax-table old-syntax-table))))) + +(provide 'xscheme) + +;;; xscheme.el ends here hunk ./site-lisp/http-cookies.el 1 +;;; http-cookies.el --- simple HTTP cookies implementation + +;; Copyright (C) 2004, David Hansen + +;; Author: David Hansen +;; Maintainer: David Hansen +;; Version: 1.0.0 +;; Keywords: hypermedia + +;; This file is not part of GNU Emacs. + +;; This is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This 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 General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + + +;;; Commentary: + +;; Implementation of old netscape cookies (used by maybe all servers) and +;; version 1 cookies. +;; +;; See http://www.faqs.org/rfcs/rfc2109.html and +;; http://wp.netscape.com/newsref/std/cookie_spec.html + +;;; Change log: + +;;; TODO: + +;; - whitelist +;; - blacklist +;; - reading from file, saving to file +;; - expire + +;;; Code: + +(require 'time-date) + +(defconst http-cookies-version "1.0.0") + +(defgroup http-emacs () + "Simple HTTP client implementation in elisp.") + +(defcustom http-emacs-use-cookies nil + "Use cookies in the http-emacs package. *EXPERIMENTAL*" + :type 'boolean + :group 'http-emacs) + +(defcustom http-emacs-cookie-file "~/.emacs-cookies" + "*File where to store the cookies." + :type 'file + :group 'http-emacs) + +(defconst http-token-value-regexp + "^[ \t]*\\(.*?\\)[ \t]*=[ \t]*\"?\\(.*?\\)\"?[ \t]*;?[ \t]*$" + "Regexp to match a token=\"value\"; in a cookie.") + +(defvar http-cookies-accept-functions + '(http-cookie-check-path + http-cookie-check-domain + http-cookie-check-hostname) + "*List of functions used to determine if we accept a cookie or not. +If one of these function returns nil the cookie will be rejected. Each +function can access the free variables `cookie', `host' (from the url) +`path' (from the URL) and `url' to make its decision.") + +(defvar http-cookies-host-hash + (make-hash-table :test 'equal) + "Hash to look up cookies by host name.") + +(defvar http-cookies-domain-hash + (make-hash-table :test 'equal) + "Hash to look up cookies by domain.") + + + +;; functions for parsing the header + +(defun http-cookies-ns-to-rfc (line) + "Make the header value LINE a bit more RFC compatible. +Make old netscape cookies a bit more RFC 2109 compatible by quoting +the \"expires\" value. We need this to be able to properly split +the header value if there is more than one cookie." + (let ((start 0)) + (while (string-match "expires[ \t]*=[ \t]*\\([^\";]+?\\)\\(;\\|$\\)" + line start) + (setq start (match-end 0)) + (setq line (replace-match "\"\\1\"" t nil line 1))) + line)) + +(defun http-cookies-find-char-in-string (char string &optional start) + "Return the first position of CHAR in STRING. +If START is non-nil start at position START." + (unless start + (setq start 0)) + (let ((i start) (len (length string)) pos) + (while (and (not pos) (< i len)) + (when (= (aref string i) char) + (setq pos i)) + (setq i (1+ i))) + pos)) + +(defun http-cookies-find-quoted-strings (header-value) + "Return list of positions of quoted strings in HEADER_VALUE. +Return a list of pairs with the beginning and end of quoted strings +in a \"Set-cookie: \" header value." + (let ((start 0) qstring-pos) + (while (string-match "=[ \t]*\\(\".*?[^\\]\"\\)" header-value start) + (add-to-list 'qstring-pos (cons (match-beginning 1) (1- (match-end 1)))) + (setq start (match-end 1))) + qstring-pos)) + +(defun http-cookies-split-string (header-value sep-char) + "Split the HEADER-VALUE at the character SEP-CHAR. +Ignores SEP-CHAR if it is in a quoted string. Return a list of the +substrings." + (let ((qstrings (http-cookies-find-quoted-strings header-value)) + (start 0) (beg 0) pos in-qstring strings) + (while (setq pos (http-cookies-find-char-in-string + sep-char header-value start)) + (unless (= pos start) ; ignore empty strings + ;; check if pos is in a quoted string + (dolist (qstring-pos qstrings) + (unless in-qstring + (when (and (> pos (car qstring-pos)) (< pos (cdr qstring-pos))) + (setq in-qstring t)))) + (if in-qstring + (setq in-qstring nil) + (add-to-list 'strings (substring header-value beg pos)) + (setq beg (1+ pos)))) + (setq start (1+ pos))) + ;; add the last token + (add-to-list 'strings (substring header-value beg)) + strings)) + +(defun http-cookies-parse-cookie (string) + "Parse one cookie. +Return an alist ((NAME . VALUE) (attr1 . value1) (attr2 . value2) ...) +or nil on error." + (let (attrs error) + (dolist (attr (http-cookies-split-string string ?\;)) + (if (string-match http-token-value-regexp attr) + (add-to-list 'attrs (cons (match-string 1 attr) + (match-string 2 attr))) + ;; match the secure attribute + (if (string-match "[ \t]*\\([a-zA-Z]+\\)[ \t]*" attr) + (add-to-list 'attrs (cons (match-string 1 attr) t)) + (setq error t) + (message "Cannot parse cookie %s" string)))) + (unless error + attrs))) + +(defun http-cookies-set (url headers) + "Set the cookies from the response to a request of URL. +Set HEADERS to the headers of the response." + (let ((host (http-cookies-url-host url)) (path (http-cookies-url-path url)) + header-value cookie) + ;; The server may send several "Set-Cookie:" headers. + (dolist (line headers) + (when (equal (car line) "set-cookie") + (setq header-value (http-cookies-ns-to-rfc (cdr line))) + ;; there may be several cookies separated by "," + (dolist (raw-cookie (http-cookies-split-string header-value ?\,)) + (setq cookie (http-cookies-parse-cookie raw-cookie)) + ;; (message "%s" raw-cookie) + (when (http-cookies-accept) + ;; (message "accepted") + (http-cookies-store host cookie))))))) + + + +;; storing cookies + +(defun http-cookies-name (cookie) + "Return the name of the COOKIE." + (car (car cookie))) + +(defun http-cookies-path (cookie) + "Return the value of the path attribute of the COOKIE." + (let ((attr (or (assoc "path" cookie) (assoc "Path" cookie)))) + (when attr + (cdr attr)))) + +(defun http-cookies-domain (cookie) + "Return the value of the domain attribute of the COOKIE." + (let ((attr (or (assoc "domain" cookie) (assoc "Domain" cookie)))) + (when attr + (cdr attr)))) + +(defun http-cookies-expires (cookie) + "Return the value of the expires attribute of the COOKIE." + (let ((attr (assoc "expires" cookie))) + (when attr + (cdr attr)))) + +(defun http-cookies-max-age (cookie) + "Return the value of the Max-Age attribute of the COOKIE." + (let ((attr (assoc "Max-Age" cookie))) + (when attr + (cdr attr)))) + +(defun http-cookies-version (cookie) + "Return the value of the version attribute of the COOKIE." + (let ((version (assoc "Version" cookie))) + (when version + (if (equal version "1") + t + (message "Cookie version %s not supported." version) + nil)))) + +(defun http-cookies-equal (c1 c2) + "Return non nil if the given cookies are equal. +Old netscape cookies are equal if the name and path attributes are equal. +Version 1 cookies are equal if name path and domain are equal." + (if (and (http-cookies-version c1) (http-cookies-version c2)) + ;; version 1 cookies + (and (equal (http-cookies-name c1) (http-cookies-name c2)) + (equal (http-cookies-path c1) (http-cookies-path c2)) + (equal (http-cookies-domain c1) (http-cookies-domain c2))) + ;; netscape cookies + (and (equal (http-cookies-name c1) (http-cookies-name c2)) + (equal (http-cookies-path c1) (http-cookies-path c2))))) + +(defun http-cookies-expired (expire-string) + "Return non nil if EXPIRE-STRING is in the past." + (> (time-to-seconds (time-since expire-string)) 0.0)) + +(defun http-cookies-remove (cookie key table) + "Remove cookies \"equal\" to COOKIE from the list stored with KEY in TABLE." + (let ((cookie-list (gethash key table)) new-list) + (dolist (entry cookie-list) + (unless (http-cookies-equal entry cookie) + (add-to-list 'new-list entry))) + (when cookie-list + (remhash key table) + (puthash key new-list table)))) + +(defun http-cookies-store (host cookie) + "Store the given COOKIE from HOST in the hash tables. +Remove cookie from the tables if the given COOKIE expires in the past or +has an \"Max-Age\" of 0." + (let ((domain (http-cookies-domain cookie)) + (max-age (http-cookies-max-age cookie)) + (expires (http-cookies-expires cookie)) + (cookie-list)) + ;; remove an possible "equal" old cookie + (http-cookies-remove cookie host http-cookies-host-hash) + (when domain + (http-cookies-remove cookie domain http-cookies-domain-hash)) + ;; check if expires is in the past or Max-Age is zero + (unless (or (and max-age (= (string-to-number max-age) 0)) + (and expires (http-cookies-expired expires))) + ;; convert "Max-Age" to "expire" + (when max-age + ;; this value does not have to be in the "right" format + ;; it's enough if `parse-time-string' can parse it + (setq expires (format-time-string + "%Y-%m-%d %T %z" + (time-add (current-time) (seconds-to-time max-age)) + t)) + (setcdr (assoc "Max-Age" cookie) expires) + (setcar (assoc "Max-Age" cookie) "expires")) + (setq cookie-list (gethash host http-cookies-host-hash)) + (add-to-list 'cookie-list cookie) + (puthash host cookie-list http-cookies-host-hash) + (when domain + (setq cookie-list (gethash domain http-cookies-domain-hash)) + (add-to-list 'cookie-list cookie) + (puthash domain cookie-list http-cookies-domain-hash))))) + + + +;; building the header to send back the cookie + +(defun http-cookies-cookie-to-string (cookie) + "Return the cookie as a string to be used as a header value." + (let* ((name (http-cookies-name cookie)) + (value (cdr (assoc name cookie))) + (path (http-cookies-path cookie)) + (domain (http-cookies-domain cookie)) + (string)) + (if (http-cookies-version cookie) + ;; version 1 cookie + (progn + (setq string (concat "$Version = \"1\"; " name " = \"" value "\"")) + (when path + (setq string (concat string "; $Path = \"" path "\""))) + (when domain + (setq string (concat string "; $Domain = \"" domain "\"")))) + ;; netscape cookies + (setq string (concat name "=" value))))) + +(defun http-cookies-cookie-in-list (cookie list) + "Return non-nil if a cookie \"equal\" to the given COOKIE is in LIST." + (let ((in-list)) + (dolist (element list) + (unless in-list + (setq in-list (http-cookies-equal cookie element)))) + in-list)) + +(defun http-cookies-path-depth (cookie) + "Return the number of dashes in the path attribute of the cookie." + (let ((patch http-cookies-path cookie) (n 0) (start 0)) + (while (setq start (http-cookies-find-char-in-string ?\/ path start)) + (setq n (1+ n))) + n)) + +(defun http-cookie-path-depth-less (c1 c2) + "Return non nil if the path depth of cookie C1 is less than C2." + (< (http-cookies-path-depth c1) (http-cookies-path-depth c2))) + +(defun http-cookies-build-header (url) + "Return a pair (\"Cookie\" .
). +Use this to send back cookies to the given URL." + (let ((host (http-cookies-url-host url)) (domain) (cookie-list) (string)) + (when (string-match "^[^.]+\\(\\..+\\)" host) + (setq domain (match-string 1 host)) + (dolist (cookie (gethash host http-cookies-host-hash)) + (unless (http-cookies-expired (http-cookies-expires cookie)) + (add-to-list 'cookie-list cookie))) + (dolist (cookie (gethash domain http-cookies-domain-hash)) + (unless (or (http-cookies-cookie-in-list cookie cookie-list) + (http-cookies-expired (http-cookies-expires cookie))) + (add-to-list 'cookie-list cookie))) + (setq cookie-list (sort cookie-list 'http-cookies-path-depth-less)) + (dolist (cookie cookie-list) + (if string + (setq string (concat string "; " + (http-cookies-cookie-to-string cookie))) + (setq string (http-cookies-cookie-to-string cookie))))) + (cons "Cookie" string))) + + + +;; extract parts of the url + +(defun http-cookies-url-host (url) + "Return the hostname of URL" + (unless (string-match + "http://\\([^/:]+\\)\\(:\\([0-9]+\\)\\)?/\\(.*/\\)?\\([^:]*\\)" + url) + (error "Cannot parse URL %s." url)) + (match-string 1 url)) + +(defun http-cookies-url-path (url) + "Return the path of the URL." + (unless (string-match + "http://\\([^/:]+\\)\\(:\\([0-9]+\\)\\)?/\\(.*/\\)?\\([^:]*\\)" + url) + (error "Cannot parse URL %s." url)) + (concat "/" (or (match-string 4 url) ""))) + + + +;; functions to check the cookie (implementation of 4.3.2 of RFC 2109) + +(defun http-cookies-accept () + "Return non nil if the cookie should be accepted. +The tests are based on the functions in `http-cookies-accept-functions'." + (let ((accept t)) + (dolist (fun http-cookies-accept-functions) + (when accept + (setq accept (funcall fun)))) + accept)) + +(defun http-cookie-check-path () + "Return nil if the \"path\" attribute is not a prefix of th URL." + (let ((cookie-path (cdr (assoc "path" cookie)))) + (if cookie-path + (if (string-match (concat "^" cookie-path) path) + t + (message "Rejecting cookie: path attribute \"%s\" is not a prefix\ + of the URL %s." cookie-path url) + nil) + t))) + +(defun http-cookie-check-domain () + "Return nil if the domain is bogus. +Return nil if the domain does not start with a \".\" or does not contain +an embedded dot." + (let ((domain (cdr (assoc "domain" cookie)))) + (if domain + (if (string-match "^\\.[^.]+\\.[^.]+" domain) + t + (message "Rejection cookie: domain \"%s\" does not start with a dot\ + or does not contain an embedded dot." domain) + nil) + t))) + +(defun http-cookie-check-hostname () + "Return nil if the domain doesn't match the host. +Return nil if the domain attribute does not match the host name or the +host name without the domain attribute still contains one or more dots." + ;; FIXME: hostname might be an IP address + (let ((domain (cdr (assoc "domain" cookie)))) + (if (not domain) + t + (when (string-match (concat domain "$") host) + (not (http-cookies-find-char-in-string + ?\. (substring host 0 (match-beginning 0)))))))) + + + +(provide 'http-cookies) + +;;; http-cookies.el ends here hunk ./site-lisp/http-get.el 1 +;;; http-get.el --- simple HTTP GET + +;; Copyright (C) 2002, 2003 Alex Schroeder + +;; Author: Alex Schroeder +;; Pierre Gaston +;; David Hansen +;; Maintainer: David Hansen +;; Version: 1.0.15 +;; Keywords: hypermedia +;; URL: http://www.emacswiki.org/cgi-bin/wiki.pl?HttpGet + +;; This file is not part of GNU Emacs. + +;; This is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This 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 General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + + +;;; Commentary: + +;; Use `http-get' to download an URL. + +;;; Change log: + +;; 1.0.15 +;; - made `http-parse-headers' RFC 2616 compatible (removing whitespaces, +;; headers may spawn several line) +;; - log message headers +;; - made most variables buffer local with `make-variable-buffer-local' +;; 1.0.14 +;; - Removed attempt to fix bug in 1.0.12, not needed anymore since 1.0.13. +;; 1.0.13 +;; - The string is now not anymore decoded in the http-filter. +;; You have to run `http-decode' yourself. +;; 1.0.12 +;; - Hopefully fixed the bug with inserting "half" multi byte chars. +;; 1.0.11 +;; - Added (setq string (string-make-unibyte string)) to http-filter +;; this seems to solve problems with multi byte chars. +;; - Fixed bug when building the headers. +;; - Fixed indentation (please guys, read the coding conventions in the +;; elisp manual) +;; - Replaced string-bytes with length (string-bytes shouldn't be needed +;; anymore as we force the string to be unibyte) +;; 1.0.10 +;; - Fix some codings problems again. +;; 1.0.9 +;; - Added better coding support. +;; 1.0.8 +;; - Rewrote the parser. +;; - Correction to the http 1.0 usage. +;; 1.0.3 +;; - Move http-url-encode from http-post.el to http-get.el. +;; - Add a param to http-get to specify the encoding of the params in the url. + +;;; Code: + +(require 'hexl) +(require 'http-cookies) + +(defvar http-get-version "1.0.15") + +;; Proxy +(defvar http-proxy-host nil + "*If nil dont use proxy, else name of proxy server.") + +(defvar http-proxy-port nil + "*Port number of proxy server. Default is 80.") + +(defvar http-coding 'iso-8859-1 + "Default coding to be use when the string is inserted in the buffer. +This coding will be modified on Finding the content-type header") +(make-variable-buffer-local 'http-coding) + +(defvar http-filter-pre-insert-hook '(http-parser) + "Hook run by the `http-filter'. +This is called whenever a chunk of input arrives, before it is +inserted into the buffer. If you want to modify the string that gets +inserted, modify the variable `string' which is dynamically bound to +what will get inserted in the end. The string will be inserted at +the `process-mark', which you can get by calling \(process-mark proc). +`proc' is dynamically bound to the process, and the current buffer +is the very buffer where the string will be inserted.") + +(defvar http-filter-post-insert-hook nil + "Hook run by the `http-filter'. +This is called whenever a chunk of input arrives, after it has been +inserted, but before the `process-mark' has moved. Therefore, the new +text lies between the `process-mark' and point. You can get the values +of the `process-mark' by calling (process-mark proc). Please take care +to leave point at the right place, eg. by wrapping your code in a +`save-excursion'.") + +(defun http-filter (proc string) + "Filter function for HTTP buffers. +See `http-filter-pre-insert-hook' and `http-filter-post-insert-hook' +for places where you can do your own stuff such as HTML rendering. +Argument PROC is the process that is filtered. +Argument STRING is the string outputted by the process." + ;; emacs seems to screw this sometimes + (when (fboundp 'string-make-unibyte) + (setq string (string-make-unibyte string))) + (with-current-buffer (process-buffer proc) + (let ((moving (= (point) (process-mark proc)))) + (save-excursion + " Insert the text, advancing the process marker." + (goto-char (process-mark proc)) + (run-hooks 'http-filter-pre-insert-hook) + ;; Note: the string is inserted binary in a unibyte buffer + (insert string) + (run-hooks 'http-filter-post-insert-hook) + (set-marker (process-mark proc) (point))) + (if moving (goto-char (process-mark proc)))))) + +(defvar http-status-code nil + "The status code returned for the current buffer. +This is set by the function `http-headers'.") +(make-variable-buffer-local 'http-status-code) + +(defvar http-reason-phrase nil + "The reason phrase returned for the `http-status-code'. +This is set by the function `http-headers'.") +(make-variable-buffer-local 'http-reason-phrase) + +(defvar http-headers nil + "An alist of the headers that have been parsed and removed from the buffer. +The headers are stored as an alist. +This is set by the function `http-headers'.") +(make-variable-buffer-local 'http-headers) + +(defvar http-parser-state 'status-line + "Parser status.") +(make-variable-buffer-local 'http-parser-state) + +(defvar http-unchunk-chunk-size 0 + "Size of the current unfinished chunk.") +(make-variable-buffer-local 'http-unchunk-chunk-size) + +(defvar http-not-yet-parsed "" + "Received bytes that have not yet been parsed.") +(make-variable-buffer-local 'http-not-yet-parsed) + +(defvar http-host "" + "The host to which we have sent the request.") +(make-variable-buffer-local 'http-host) + +(defvar http-url "" + "The requested URL.") +(make-variable-buffer-local 'http-url) + +(defun http-parser () + "Simple parser for http message. +Parse the status line, headers and chunk." + (let ((parsed-string (concat http-not-yet-parsed string)) content-type) + (setq string "") + (setq http-not-yet-parsed "") + (while (> (length parsed-string) 0) + (cond + + ((eq http-parser-state 'status-line) + ;; parsing status line + (if (string-match "HTTP/[0-9.]+ \\([0-9]+\\) \\(.*\\)\r\n" + parsed-string) + (progn + (setq http-status-code + (string-to-number (match-string 1 parsed-string))) + (setq http-reason-phrase (match-string 2 parsed-string)) + (setq http-parser-state 'header) + (setq parsed-string (substring parsed-string (match-end 0)))) + ;; status line not found + (setq http-not-yet-parsed parsed-string) + (setq parsed-string ""))) + + ((eq http-parser-state 'header) + ;; parsing headers + (if (string-match "\r\n\r\n" parsed-string) + (let ((end-headers (match-end 0))) + (setq http-headers + (http-parse-headers + (substring parsed-string 0 (match-beginning 0)))) + (if (string= "chunked" + (cdr (assoc "transfer-encoding" http-headers))) + (setq http-parser-state 'chunked) + (setq http-parser-state 'dump)) + (when (and + (setq content-type + (cdr (assoc "content-type" http-headers))) + (string-match "charset=\\(.*\\)" content-type)) + (setq http-coding + (intern-soft (downcase (match-string 1 content-type))))) + (setq parsed-string (substring parsed-string end-headers)) + ;; set cookies + (when http-emacs-use-cookies + (http-cookies-set http-url http-headers))) + ;; we don't have all the headers yet + (setq http-not-yet-parsed parsed-string) + (setq parsed-string ""))) + + ((eq http-parser-state 'chunked) + ;; parsing chunked content + (if (> (length parsed-string) http-unchunk-chunk-size) + (progn + (setq string (concat string + (substring parsed-string 0 + http-unchunk-chunk-size))) + (setq parsed-string + (substring parsed-string http-unchunk-chunk-size)) + (setq http-unchunk-chunk-size 0) + + (if (string-match "\\([0-9a-f]+\\)[^\r^\b]*\\(\r\n\\)" + parsed-string) + (if (> (setq http-unchunk-chunk-size + (hexl-hex-string-to-integer + (match-string 1 parsed-string))) + 0) + (setq parsed-string + (substring parsed-string (match-end 2))) + ;; chunk 0 found we just burry it + (setq parsed-string "") + (setq http-parser-state 'trailer)) + ;; we don't have the next chunk-size yet + (setq http-not-yet-parsed parsed-string) + (setq parsed-string ""))) + ;; the current chunk is not finished yet + (setq string (concat string parsed-string)) + (setq http-unchunk-chunk-size + (- http-unchunk-chunk-size (length parsed-string))) + (setq parsed-string ""))) + + ((eq http-parser-state 'trailer) + ;; parsing trailer + (setq parsed-string "")) + + ((eq http-parser-state 'dump) + (setq string parsed-string) + (setq parsed-string "")))))) + + +(defun http-parse-headers (header-string) + "Parse the header string. +Argument HEADER-STRING A string containing a header list." + ;; headers may spawn several line if the nth, n>1, line starts with + ;; at least one whitespace + (setq header-string (replace-regexp-in-string "\r\n[ \t]+" " " + header-string)) + (let ((lines-list (split-string header-string "\r\n"))) + (mapcar (lambda (line) + (if (string-match ":[ \t]+\\(.*?\\)[ \t]*$" line) + (cons (downcase (substring line 0 (match-beginning 0))) + (match-string 1 line)) + line)) + lines-list))) + + +;; URL encoding for parameters +(defun http-url-encode (str content-type) + "URL encode STR using CONTENT-TYPE as the coding system." + (apply 'concat + (mapcar (lambda (c) + (if (or (and (>= c ?a) (<= c ?z)) + (and (>= c ?A) (<= c ?Z)) + (and (>= c ?0) (<= c ?9))) + (string c) + (format "%%%02x" c))) + (encode-coding-string str content-type)))) + + +(defun http-decode-buffer () + "Decode buffer according to the buffer local variable `http-coding'." + (when (and + (fboundp 'set-buffer-multibyte) + (fboundp 'multibyte-string-p)) + (when (multibyte-string-p (decode-coding-string "test" http-coding)) + (set-buffer-multibyte t))) + (decode-coding-region (point-min) (point-max) http-coding)) + +;; Debugging +(defvar http-log-function 'ignore + "Function to call for log messages.") + +(defun http-log (str) + "Log STR using `http-log-function'. +The default value just ignores STR." + (funcall http-log-function str)) + + +(defun http-get-debug (url &optional headers version) + "Debug the call to `http-get'." + (interactive "sURL: ") + (let* ((http-log-function (lambda (str) + (save-excursion + ;; dynamic binding -- buf from http-get is used + (set-buffer buf) + (insert str)))) + proc) + (when (get-buffer "*Debug HTTP-GET*") + (kill-buffer "*Debug HTTP-GET*")) + (setq proc (http-get url headers nil version)) + (set (make-local-variable 'http-filter-pre-insert-hook) nil) + (set (make-local-variable 'http-filter-post-insert-hook) nil) + (rename-buffer "*Debug HTTP-GET*"))) + + +;; The main function + +;;;###autoload +(defun http-get (url &optional headers sentinel version bufname content-type) + "Get URL in a buffer, and return the process. +You can get the buffer associated with this process using +`process-buffer'. + +The optional HEADERS are an alist where each element has the form +\(NAME . VALUE). Both must be strings and will be passed along with +the request. + +With optional argument SENTINEL, the buffer is not shown. It is the +responsibility of the sentinel to show it, if appropriate. A sentinel +function takes two arguments, process and message. It is called when +the process is killed, for example. This is useful when specifying a +non-persistent connection. By default, connections are persistent. +Add \(\"Connection\" . \"close\") to HEADERS in order to specify a +non-persistent connection. Usually you do not need to specify a +sentinel, and `ignore' is used instead, to prevent a message being +printed when the connection is closed. + +If you want to filter the content as it arrives, bind +`http-filter-pre-insert-hook' and `http-filter-post-insert-hook'. + +The optional argument VERSION specifies the HTTP version to use. It +defaults to version 1.0, such that the connection is automatically +closed when the entire document has been downloaded. This will then +call SENTINEL, if provided. If no sentinel is provided, `ignore' will +be used in order to prevent a message in the buffer when the process +is killed. + +CONTENT-TYPE is a coding system to use for the encoding of the url +param value. Its upper case print name will be used for the server. +Possible values are `iso-8859-1' or `euc-jp' and others. + +The coding system of the process is set to `binary', because we need to +distinguish between \\r and \\n. To correctly decode the text later, +use `decode-coding-region' and get the coding system to use from +`http-headers'." + (interactive "sURL: ") + (setq version (or version 1.0)) + (let* (host dir file port proc buf command start-line (message-headers "") ) + (unless (string-match + "http://\\([^/:]+\\)\\(:\\([0-9]+\\)\\)?/\\(.*/\\)?\\([^:]*\\)" + url) + (error "Cannot parse URL %s." url)) + (unless bufname + (setq bufname (format "*HTTP GET %s *" url))) + + (setq host (match-string 1 url) + port (or (and (setq port (match-string 3 url)) + (string-to-int port)) 80) + dir (or (match-string 4 url) "") + file (or (match-string 5 url) "") + buf (get-buffer-create bufname) + proc (open-network-stream + (concat "HTTP GET " url) buf + (if http-proxy-host http-proxy-host host) + (if http-proxy-port http-proxy-port port) )) + (if sentinel + (set-buffer buf) + (switch-to-buffer buf)) + (erase-buffer) + (kill-all-local-variables) + (with-current-buffer buf + (setq http-host host) + (setq http-url url)) + (if content-type + (setq file + (replace-regexp-in-string + "=[^&]+" + (lambda (param) + (concat "=" + (http-url-encode (substring param 1) content-type))) + file))) + (setq start-line + (concat (format "GET %s%s%s HTTP/%.1f\r\n" + (if http-proxy-host + (concat "http://" host "/") "/") dir file version) + (format "Host: %s\r\n" host))) + (when http-emacs-use-cookies + (let ((cookie (http-cookies-build-header url))) + (when cookie (add-to-list 'headers cookie)))) + (when headers + (setq message-headers (mapconcat (lambda (pair) + (concat (car pair) ": " (cdr pair))) + headers + "\r\n"))) + ;; mapconcat doesn't append the \r\n for the final line + (setq command (format "%s%s\r\n\r\n" start-line message-headers)) + (http-log (format "Connecting to %s %d\nCommand:\n%s\n" host port command)) + (http-log message-headers) + (set-process-sentinel proc (or sentinel 'ignore)) + (set-process-coding-system proc 'binary 'binary) ; we need \r\n + ;; we need this to be able to correctly decode the buffer with + ;; decode-coding-region later + (when (fboundp 'set-buffer-multibyte) + (with-current-buffer buf (set-buffer-multibyte nil))) + (set-process-filter proc 'http-filter) + (set-marker (process-mark proc) (point-max)) + (process-send-string proc command) + + proc)) + + +;; needed for xemacs. c&p from gnu emacs cvs sources +(unless (fboundp 'replace-regexp-in-string) + (defun replace-regexp-in-string (regexp rep string &optional + fixedcase literal subexp start) + (let ((l (length string)) + (start (or start 0)) + matches str mb me) + (save-match-data + (while (and (< start l) (string-match regexp string start)) + (setq mb (match-beginning 0) + me (match-end 0)) + (when (= me mb) (setq me (min l (1+ mb)))) + (string-match regexp (setq str (substring string mb me))) + (setq matches + (cons (replace-match (if (stringp rep) + rep + (funcall rep (match-string 0 str))) + fixedcase literal str subexp) + (cons (substring string start mb) + matches))) + (setq start me)) + (setq matches (cons (substring string start l) matches)) + (apply #'concat (nreverse matches)))))) + +(provide 'http-get) + +;;; http-get.el ends here hunk ./site-lisp/http-post.el 1 +;;; http-post.el --- simple HTTP POST + +;; Copyright (C) 2002, 2003 Alex Schroeder + +;; Author: Alex Schroeder +;; Maintainer: David Hansen +;; Version: 1.0.5 +;; Keywords: hypermedia +;; URL: http://www.emacswiki.org/cgi-bin/wiki.pl?HttpPost + +;; This file is not part of GNU Emacs. + +;; This is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This 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 General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Use `http-post' to post to a URL. + +;;; Change Log: + +;; 1.0.5 +;; - Added experimental cookies support. +;; 1.0.4 +;; - Fixed bug in `http-post' that ignored the headers argument. +;; 1.0.3 +;; - Minor fix. +;; 1.0.1 +;; - Moved http-url-encode to http-get. + +;;; Code: + +(require 'http-get) +(require 'http-cookies) + +(defvar http-post-version "1.0.5") + + +;; The main function + +(defun http-post (url parameters content-type &optional headers sentinel + version verbose bufname) + "Post to a URL in a buffer using HTTP 1.1, and return the process. +You can get the buffer associated with this process using +`process-buffer'. + + + +PARAMETERS is an alist of parameters to use. Each element has the +form \(NAME . VALUE). These usually correspond to successful controls +on HTML forms. + +CONTENT-TYPE is a coding system to use. Its upper case print name +will be used for the server. Possible values are `iso-8859-1' or +`euc-jp' and others. + +The optional HEADERS are an alist where each element has the form +\(NAME . VALUE). Both must be strings and will be passed along with +the request. The reason CONTENT-TYPE is not just passed along as one +of the headers is that part of the Content-Type value is fixed and +cannot be changed: The basic encoding is implemented using +`html-url-encode' and is called application/x-www-form-urlencoded. + +With optional argument SENTINEL, the buffer is not shown. It is the +responsibility of the sentinel to show it, if appropriate. A sentinel +function takes two arguments, process and message. It is called when +the process is killed, for example. This is useful when specifying a +non-persistent connection. By default, connections are persistent. +Add \(\"Connection\" . \"close\") to HEADERS in order to specify a +non-persistent connection. Usually you do not need to specify a +sentinel, and `ignore' is used instead, to prevent a message being +printed when the connection is closed. + +If you want to filter the content as it arrives, bind +`http-filter-pre-insert-hook' and `http-filter-post-insert-hook'. + +The optional argument VERSION specifies the HTTP version to use. It +defaults to version 1.0, such that the connection is automatically +closed when the entire document has been downloaded. + +If the optional argument VERBOSE is non-nil, a message will show the +command sent to the server. + +The coding system of the process is set to `binary', because we need to +distinguish between \\r and \\n. To correctly decode the text later, +use `decode-coding-region' and get the coding system to use from +`http-headers'." + (interactive) + (setq version (or version 1.0)) + (let* (host dir file port proc buf header body content-length) + (unless (string-match + "http://\\([^/:]+\\)\\(:\\([0-9]+\\)\\)?/\\(.*/\\)?\\([^:]*\\)" + url) + (error "Cannot parse URL %s" url)) + (unless bufname (setq bufname + (format "*HTTP POST %s *" url))) + (setq host (match-string 1 url) + port (or (and (setq port (match-string 3 url)) + (string-to-int port)) 80) + dir (or (match-string 4 url) "") + file (or (match-string 5 url) "") + buf (get-buffer-create bufname) + proc (open-network-stream + (concat "HTTP POST " url) + buf (if http-proxy-host http-proxy-host host) + (if http-proxy-port http-proxy-port port))) + (set-process-sentinel proc (or sentinel 'ignore)) + (set-process-coding-system proc 'binary 'binary) ; we need \r\n + (set-process-filter proc 'http-filter) + (set-marker (process-mark proc) (point-min) buf) + (if sentinel + (set-buffer buf) + (switch-to-buffer buf)) + (erase-buffer) + (kill-all-local-variables) + + (with-current-buffer buf + (setq http-host host) + (setq http-url url)) + + (let (result) + (dolist (param parameters) + (setq result (cons (concat (car param) "=" + (http-url-encode (cdr param) + content-type)) + result))) + (setq body (mapconcat 'identity result "&"))) + + (setq header + (concat (format "POST %s%s%s HTTP/%.1f\r\n" + (if http-proxy-host + (concat "http://" host "/") + "/") dir file version) + (format "Host: %s\r\n" host) + "Content-Type: application/x-www-form-urlencoded" + (format "; charset=%s\r\n" + (upcase (symbol-name content-type))) + (format "Content-Length: %d\r\n" (length body)))) + + (when http-emacs-use-cookies + (let ((cookie (http-cookies-build-header url))) + (when cookie (add-to-list 'headers cookie)))) + (if headers + (setq header (concat header + (mapconcat (lambda (pair) + (concat (car pair) ": " (cdr pair))) + headers + "\r\n") + "\r\n\r\n")) + (setq header (concat header "\r\n"))) + (when verbose + ;;(when t + (message "%s" (concat header body "\n\n"))) + (process-send-string proc (concat header body "\r\n")) + proc)) + + +(provide 'http-post) + +;;; http-post.el ends here hunk ./site-lisp/javascript.el 1 +;;; javascript.el --- Major mode for editing JavaScript source text + +;; Copyright (C) 2006 Karl Landström + +;; Author: Karl Landström +;; Maintainer: Karl Landström +;; Version: 2.0 Beta 4 +;; Keywords: languages, oop + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This file 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 General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: +;; +;; The main features of this JavaScript mode are syntactic +;; highlighting (enabled with `font-lock-mode' or +;; `global-font-lock-mode'), automatic indentation and filling of +;; comments. +;; +;; This package has (only) been tested with GNU Emacs 21.4 (the latest +;; stable release). +;; +;; Installation: +;; +;; Put this file in a directory where Emacs can find it (`C-h v +;; load-path' for more info). Then add the following lines to your +;; Emacs initialization file: +;; +;; (add-to-list 'auto-mode-alist '("\\.js\\'" . javascript-mode)) +;; (autoload 'javascript-mode "javascript" nil t) +;; +;; General Remarks: +;; +;; This mode assumes that block comments are not nested inside block +;; comments and that strings do not contain line breaks. +;; +;; Exported names start with "javascript-" whereas private names start +;; with "js-". +;; +;; Changes: +;; +;; See javascript.el.changelog. + +;;; Code: + +(require 'cc-mode) +(require 'font-lock) +(require 'newcomment) + +(defcustom javascript-indent-level 3 + "Number of spaces for each indentation step.") + +(defcustom javascript-auto-indent-flag t + "Automatic indentation with punctuation characters. If non-nil, the +current line is indented when certain punctuations are inserted.") + + +;; --- Keymap --- + +(defvar javascript-mode-map nil + "Keymap used in JavaScript mode.") + +(unless javascript-mode-map + (setq javascript-mode-map (make-sparse-keymap))) + +(when javascript-auto-indent-flag + (mapc (lambda (key) + (define-key javascript-mode-map key 'javascript-insert-and-indent)) + '("{" "}" "(" ")" ":" ";" ","))) + +(defun javascript-insert-and-indent (key) + "Run command bound to key and indent current line. Runs the command +bound to KEY in the global keymap and indents the current line." + (interactive (list (this-command-keys))) + (call-interactively (lookup-key (current-global-map) key)) + (indent-according-to-mode)) + + +;; --- Syntax Table And Parsing --- + +(defvar javascript-mode-syntax-table + (let ((table (make-syntax-table))) + (c-populate-syntax-table table) + + ;; The syntax class of underscore should really be `symbol' ("_") + ;; but that makes matching of tokens much more complex as e.g. + ;; "\\" matches part of e.g. "_xyz" and "xyz_abc". Defines + ;; it as word constituent for now. + (modify-syntax-entry ?_ "w" table) + + table) + "Syntax table used in JavaScript mode.") + + +(defun js-re-search-forward-inner (regexp &optional bound count) + "Auxiliary function for `js-re-search-forward'." + (let ((parse) + (saved-point (point-min))) + (while (> count 0) + (re-search-forward regexp bound) + (setq parse (parse-partial-sexp saved-point (point))) + (cond ((nth 3 parse) + (re-search-forward + (concat "\\([^\\]\\|^\\)" (string (nth 3 parse))) + (save-excursion (end-of-line) (point)) t)) + ((nth 7 parse) + (forward-line)) + ((or (nth 4 parse) + (and (eq (char-before) ?\/) (eq (char-after) ?\*))) + (re-search-forward "\\*/")) + (t + (setq count (1- count)))) + (setq saved-point (point)))) + (point)) + + +(defun js-re-search-forward (regexp &optional bound noerror count) + "Search forward but ignore strings and comments. Invokes +`re-search-forward' but treats the buffer as if strings and +comments have been removed." + (let ((saved-point (point)) + (search-expr + (cond ((null count) + '(js-re-search-forward-inner regexp bound 1)) + ((< count 0) + '(js-re-search-backward-inner regexp bound (- count))) + ((> count 0) + '(js-re-search-forward-inner regexp bound count))))) + (condition-case err + (eval search-expr) + (search-failed + (goto-char saved-point) + (unless noerror + (error (error-message-string err))))))) + + +(defun js-re-search-backward-inner (regexp &optional bound count) + "Auxiliary function for `js-re-search-backward'." + (let ((parse) + (saved-point (point-min))) + (while (> count 0) + (re-search-backward regexp bound) + (setq parse (parse-partial-sexp saved-point (point))) + (cond ((nth 3 parse) + (re-search-backward + (concat "\\([^\\]\\|^\\)" (string (nth 3 parse))) + (save-excursion (beginning-of-line) (point)) t)) + ((nth 7 parse) + (goto-char (nth 8 parse))) + ((or (nth 4 parse) + (and (eq (char-before) ?/) (eq (char-after) ?*))) + (re-search-backward "/\\*")) + (t + (setq count (1- count)))))) + (point)) + + +(defun js-re-search-backward (regexp &optional bound noerror count) + "Search backward but ignore strings and comments. Invokes +`re-search-backward' but treats the buffer as if strings and +comments have been removed." + (let ((saved-point (point)) + (search-expr + (cond ((null count) + '(js-re-search-backward-inner regexp bound 1)) + ((< count 0) + '(js-re-search-forward-inner regexp bound (- count))) + ((> count 0) + '(js-re-search-backward-inner regexp bound count))))) + (condition-case err + (eval search-expr) + (search-failed + (goto-char saved-point) + (unless noerror + (error (error-message-string err))))))) + + +;; --- Font Lock --- + +(defconst js-function-heading-1-re + "^[ \t]*function[ \t]+\\(\\w+\\)" + "Regular expression matching the start of a function header.") + +(defconst js-function-heading-2-re + "^[ \t]*\\(\\w+\\)[ \t]*:[ \t]*function\\>" + "Regular expression matching the start of a function entry in + an associative array.") + +(defconst js-keyword-re + (regexp-opt '("abstract" "break" "case" "catch" "class" "const" + "continue" "debugger" "default" "delete" "do" "else" + "enum" "export" "extends" "final" "finally" "for" + "function" "goto" "if" "implements" "import" "in" + "instanceof" "interface" "native" "new" "package" + "private" "protected" "public" "return" "static" + "super" "switch" "synchronized" "this" "throw" + "throws" "transient" "try" "typeof" "var" "void" + "volatile" "while" "with") 'words) + "Regular expression matching any JavaScript keyword.") + +(defconst js-basic-type-re + (regexp-opt '("boolean" "byte" "char" "double" "float" "int" "long" + "short" "void") 'words) + "Regular expression matching any predefined type in JavaScript.") + +(defconst js-constant-re + (regexp-opt '("false" "null" "true") 'words) + "Regular expression matching any future reserved words in JavaScript.") + + +(defconst js-font-lock-keywords-1 + (list + "\\" + (list js-function-heading-1-re 1 font-lock-function-name-face) + (list js-function-heading-2-re 1 font-lock-function-name-face) + (list "[[:punct:]][[:blank:]]*\\(/.*?/\\w*\\)" 1 font-lock-string-face)) + "Level one font lock.") + +(defconst js-font-lock-keywords-2 + (append js-font-lock-keywords-1 + (list (list js-keyword-re 1 font-lock-keyword-face) + (cons js-basic-type-re font-lock-type-face) + (cons js-constant-re font-lock-constant-face))) + "Level two font lock.") + +(defconst js-font-lock-keywords-3 + (append js-font-lock-keywords-2 + (list + (list + (concat "\\<\\(const\\|var\\)\\>\\|" js-basic-type-re "\\|" + js-function-heading-1-re "\\|" js-function-heading-2-re) + (list "\\(\\w+\\)[ \t]*\\(,\\|=[ \t]*\\(\".*?\"\\|'.*?'\\|{.*?}\\|.*?,\\)\\|.*\\)" + nil + nil + '(1 font-lock-variable-name-face))))) + "Level three font lock.") + +(defconst js-font-lock-keywords + '(js-font-lock-keywords-3 js-font-lock-keywords-1 js-font-lock-keywords-2 + js-font-lock-keywords-3) + "See `font-lock-keywords'.") + + +;; --- Indentation --- + +(defconst js-possibly-braceless-keyword-re + (regexp-opt + '("catch" "do" "else" "finally" "for" "if" "try" "while" "with") + 'words) + "Regular expression matching keywords that are optionally + followed by an opening brace.") + +(defconst js-indent-operator-re + (concat "[-+*/%<>=&^|?:]\\([^-+*/]\\|$\\)\\|" + (regexp-opt '("in" "instanceof") 'words)) + "Regular expression matching operators that affect indentation + of continued expressions.") + + +(defun js-looking-at-operator-p () + "Return non-nil if text after point is an operator (that is not +a comma)." + (save-match-data + (and (looking-at js-indent-operator-re) + (or (not (looking-at ":")) + (save-excursion + (and (js-re-search-backward "[?:{]\\|\\" nil t) + (looking-at "?"))))))) + + +(defun js-continued-expression-p () + "Returns non-nil if the current line continues an expression." + (save-excursion + (back-to-indentation) + (or (js-looking-at-operator-p) + (and (js-re-search-backward "\n" nil t) + (progn + (skip-chars-backward " \t") + (backward-char) + (and (js-looking-at-operator-p) + (and (progn (backward-char) + (not (looking-at "++\\|--\\|/[/*]")))))))))) + + +(defun js-end-of-do-while-loop-p () + "Returns non-nil if word after point is `while' of a do-while +statement, else returns nil. A braceless do-while statement +spanning several lines requires that the start of the loop is +indented to the same column as the current line." + (interactive) + (save-excursion + (save-match-data + (when (looking-at "\\s-*\\") + (if (save-excursion + (skip-chars-backward "[ \t\n]*}") + (looking-at "[ \t\n]*}")) + (save-excursion + (backward-list) (backward-word 1) (looking-at "\\")) + (js-re-search-backward "\\" (point-at-bol) t) + (or (looking-at "\\") + (let ((saved-indent (current-indentation))) + (while (and (js-re-search-backward "^[ \t]*\\<" nil t) + (/= (current-indentation) saved-indent))) + (and (looking-at "[ \t]*\\") + (not (js-re-search-forward + "\\" (point-at-eol) t)) + (= (current-indentation) saved-indent))))))))) + + +(defun js-ctrl-statement-indentation () + "Returns the proper indentation of the current line if it +starts the body of a control statement without braces, else +returns nil." + (save-excursion + (back-to-indentation) + (when (save-excursion + (and (> (count-lines (point-min) (point)) 1) + (not (looking-at "{")) + (js-re-search-backward "[[:graph:]]" nil t) + (not (looking-at "[{([]")) + (progn + (forward-char) + (backward-sexp) + (when (looking-at "(") (backward-word 1)) + (and (save-excursion + (skip-chars-backward " \t}" (point-at-bol)) + (bolp)) + (looking-at js-possibly-braceless-keyword-re) + (not (js-end-of-do-while-loop-p)))))) + (save-excursion + (goto-char (match-beginning 0)) + (+ (current-indentation) javascript-indent-level))))) + + +(defun js-proper-indentation (parse-status) + "Return the proper indentation for the current line." + (save-excursion + (back-to-indentation) + (let ((ctrl-stmt-indent (js-ctrl-statement-indentation)) + (same-indent-p (looking-at "[]})]\\|\\\\|\\")) + (continued-expr-p (js-continued-expression-p))) + (cond (ctrl-stmt-indent) + ((nth 1 parse-status) + (goto-char (nth 1 parse-status)) + (if (looking-at "[({[][ \t]*\\(/[/*]\\|$\\)") + (let ((p (parse-partial-sexp (point-at-bol) (point)))) + (when (save-excursion (skip-chars-backward " \t)") + (looking-at ")")) + (backward-list)) + (if (nth 1 p) + (progn (goto-char (1+ (nth 1 p))) + (skip-chars-forward " \t")) + (back-to-indentation)) + (cond (same-indent-p + (current-column)) + (continued-expr-p + (+ (current-column) (* 2 javascript-indent-level))) + (t + (+ (current-column) javascript-indent-level)))) + (unless same-indent-p + (forward-char) + (skip-chars-forward " \t")) + (current-column))) + (continued-expr-p javascript-indent-level) + (t 0))))) + + +(defun javascript-indent-line () + "Indent the current line as JavaScript source text." + (interactive) + (let ((parse-status + (save-excursion (parse-partial-sexp (point-min) (point-at-bol)))) + (offset (- (current-column) (current-indentation)))) + (when (not (nth 8 parse-status)) + (indent-line-to (js-proper-indentation parse-status)) + (when (> offset 0) (forward-char offset))))) + + +;; --- Filling --- + +;; FIXME: It should be possible to use the more sofisticated function +;; `c-fill-paragraph' in `cc-cmds.el' instead. However, just setting +;; `fill-paragraph-function' to `c-fill-paragraph' does not work; +;; inside `c-fill-paragraph', `fill-paragraph-function' evaluates to +;; nil!? + +(defun js-backward-paragraph () + "Move backward to start of paragraph. Postcondition: Point is at +beginning of buffer or the previous line contains only whitespace." + (forward-line -1) + (while (not (or (bobp) (looking-at "^[ \t]*$"))) + (forward-line -1)) + (when (not (bobp)) (forward-line 1))) + + +(defun js-forward-paragraph () + "Move forward to end of paragraph. Postcondition: Point is at +end of buffer or the next line contains only whitespace." + (forward-line 1) + (while (not (or (eobp) (looking-at "^[ \t]*$"))) + (forward-line 1)) + (when (not (eobp)) (backward-char 1))) + + +(defun js-fill-block-comment-paragraph (parse-status justify) + "Fill current paragraph as a block comment. PARSE-STATUS is the +result of `parse-partial-regexp' from beginning of buffer to +point. JUSTIFY has the same meaning as in `fill-paragraph'." + (let ((offset (save-excursion + (goto-char (nth 8 parse-status)) (current-indentation)))) + (save-excursion + (save-restriction + (narrow-to-region (save-excursion + (goto-char (nth 8 parse-status)) (point-at-bol)) + (save-excursion + (goto-char (nth 8 parse-status)) + (re-search-forward "*/"))) + (narrow-to-region (save-excursion + (js-backward-paragraph) + (when (looking-at "^[ \t]*$") (forward-line 1)) + (point)) + (save-excursion + (js-forward-paragraph) + (when (looking-at "^[ \t]*$") (backward-char)) + (point))) + (goto-char (point-min)) + (while (not (eobp)) + (delete-horizontal-space) + (forward-line 1)) + (let ((fill-column (- fill-column offset)) + (fill-paragraph-function nil)) + (fill-paragraph justify)) + + ;; In Emacs 21.4 as opposed to CVS Emacs 22, + ;; `fill-paragraph' seems toadd a newline at the end of the + ;; paragraph. Remove it! + (goto-char (point-max)) + (when (looking-at "^$") (backward-delete-char 1)) + + (goto-char (point-min)) + (while (not (eobp)) + (indent-to offset) + (forward-line 1)))))) + + +(defun js-sline-comment-par-start () + "Return point at the beginning of the line where the current +single-line comment paragraph starts." + (save-excursion + (beginning-of-line) + (while (and (not (bobp)) + (looking-at "^[ \t]*//[ \t]*[[:graph:]]")) + (forward-line -1)) + (unless (bobp) (forward-line 1)) + (point))) + + +(defun js-sline-comment-par-end () + "Return point at end of current single-line comment paragraph." + (save-excursion + (beginning-of-line) + (while (and (not (eobp)) + (looking-at "^[ \t]*//[ \t]*[[:graph:]]")) + (forward-line 1)) + (unless (bobp) (backward-char)) + (point))) + + +(defun js-sline-comment-offset (line) + "Return the column at the start of the current single-line +comment paragraph." + (save-excursion + (goto-line line) + (re-search-forward "//" (point-at-eol)) + (goto-char (match-beginning 0)) + (current-column))) + + +(defun js-sline-comment-text-offset (line) + "Return the column at the start of the text of the current +single-line comment paragraph." + (save-excursion + (goto-line line) + (re-search-forward "//[ \t]*" (point-at-eol)) + (current-column))) + + +(defun js-at-empty-sline-comment-p () + "Return non-nil if inside an empty single-line comment." + (and (save-excursion + (beginning-of-line) + (not (looking-at "^.*//.*[[:graph:]]"))) + (save-excursion + (re-search-backward "//" (point-at-bol) t)))) + + +(defun js-fill-sline-comments (parse-status justify) + "Fill current paragraph as a sequence of single-line comments. +PARSE-STATUS is the result of `parse-partial-regexp' from +beginning of buffer to point. JUSTIFY has the same meaning as in +`fill-paragraph'." + (when (not (js-at-empty-sline-comment-p)) + (let* ((start (js-sline-comment-par-start)) + (start-line (1+ (count-lines (point-min) start))) + (end (js-sline-comment-par-end)) + (offset (js-sline-comment-offset start-line)) + (text-offset (js-sline-comment-text-offset start-line))) + (save-excursion + (save-restriction + (narrow-to-region start end) + (goto-char (point-min)) + (while (re-search-forward "^[ \t]*//[ \t]*" nil t) + (replace-match "") + (forward-line 1)) + (let ((fill-paragraph-function nil) + (fill-column (- fill-column text-offset))) + (fill-paragraph justify)) + + ;; In Emacs 21.4 as opposed to CVS Emacs 22, + ;; `fill-paragraph' seems toadd a newline at the end of the + ;; paragraph. Remove it! + (goto-char (point-max)) + (when (looking-at "^$") (backward-delete-char 1)) + + (goto-char (point-min)) + (while (not (eobp)) + (indent-to offset) + (insert "//") + (indent-to text-offset) + (forward-line 1))))))) + + +(defun js-trailing-comment-p (parse-status) + "Return non-nil if inside a trailing comment. PARSE-STATUS is +the result of `parse-partial-regexp' from beginning of buffer to +point." + (save-excursion + (when (nth 4 parse-status) + (goto-char (nth 8 parse-status)) + (skip-chars-backward " \t") + (not (bolp))))) + + +(defun js-block-comment-p (parse-status) + "Return non-nil if inside a block comment. PARSE-STATUS is the +result of `parse-partial-regexp' from beginning of buffer to +point." + (save-excursion + (save-match-data + (when (nth 4 parse-status) + (goto-char (nth 8 parse-status)) + (looking-at "/\\*"))))) + + +(defun javascript-fill-paragraph (&optional justify) + "If inside a comment, fill the current comment paragraph. +Trailing comments are ignored." + (interactive) + (let ((parse-status (parse-partial-sexp (point-min) (point)))) + (when (and (nth 4 parse-status) + (not (js-trailing-comment-p parse-status))) + (if (js-block-comment-p parse-status) + (js-fill-block-comment-paragraph parse-status justify) + (js-fill-sline-comments parse-status justify)))) + t) + + +;; --- Imenu --- + +(defconst js-imenu-generic-expression + (list + (list + nil + "function\\s-+\\(\\w+\\)\\s-*(" + 1)) + "Regular expression matching top level procedures. Used by imenu.") + + +;; --- Main Function --- + +;;;###autoload +(defun javascript-mode () + "Major mode for editing JavaScript source text. + +Key bindings: + +\\{javascript-mode-map}" + (interactive) + (kill-all-local-variables) + + (use-local-map javascript-mode-map) + (set-syntax-table javascript-mode-syntax-table) + (set (make-local-variable 'indent-line-function) 'javascript-indent-line) + (set (make-local-variable 'font-lock-defaults) (list js-font-lock-keywords)) + + ;; Comments + (setq comment-start "// ") + (setq comment-end "") + (set (make-local-variable 'fill-paragraph-function) + 'javascript-fill-paragraph) + + ;; Imenu + (setq imenu-case-fold-search nil) + (set (make-local-variable 'imenu-generic-expression) + js-imenu-generic-expression) + + (setq major-mode 'javascript-mode) + (setq mode-name "JavaScript") + (run-hooks 'javascript-mode-hook)) + + +(provide 'javascript-mode) +;;; javascript.el ends here hunk ./site-lisp/lj-acct.el 1 +;;; lj-acct.el --- LiveJournal account handling code for ljupdate + +;; Copyright (C) 2002, 2003, 2004, 2005 Edward O'Connor + +;; Author: Edward O'Connor +;; Keywords: convenience + +;; This file is part of ljupdate, a LiveJournal client for Emacs. + +;; ljupdate is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or +;; {at your option} any later version. + +;; ljupdate 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 +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING, or type `C-h C-c'. If +;; not, write to the Free Software Foundation at this address: + +;; Free Software Foundation +;; 51 Franklin Street, Fifth Floor +;; Boston, MA 02110-1301 +;; USA + +;;; Commentary: +;; + +;;; History: +;; + +;;; Code: + +(require 'lj-custom) + +;; backing store + +(defvar lj-acct-hash nil + "Hash in which internal account information is stored.") + +(defun lj-make-acct-hash () + "Create a new value for variable `lj-acct-hash'." + (make-hash-table :test 'equal)) + +(defun lj-acct-hash () + "Return the hash table in which internal account information is stored. +Will attempt to load our cached configuration if it is available." + (when (null lj-acct-hash) + (lj-cache-load)) + (or lj-acct-hash + (setq lj-acct-hash (lj-make-acct-hash)))) + +;; sever/user property getters/setters + +(defun lj-servers () + "Return a list of LiveJournal servers that we know about." + (let ((servers '())) + (maphash (lambda (server server-hash) + (push server servers)) + (lj-acct-hash)) + (nreverse servers))) + +(defun lj-server-get (server property) + "Fetch the value of SERVER's PROPERTY." + (let ((server-hash (gethash server (lj-acct-hash)))) + (when server-hash + (gethash property server-hash)))) + +(defun lj-users (server) + "Return a list of users on SERVER whose accounts we can use." + (let ((server-hash (gethash server (lj-acct-hash))) + (users '())) + (when server-hash + (maphash (lambda (user user-hash) + (when (and (stringp user) + (hash-table-p user-hash)) + (push user users))) + server-hash) + users))) + +(defun lj-server-put (server property value) + "Set SERVER' value of PROPERTY to VALUE." + (let ((server-hash (gethash server (lj-acct-hash)))) + (unless server-hash + (setq server-hash (make-hash-table :test 'equal)) + (puthash server server-hash (lj-acct-hash))) + (puthash property value server-hash))) + +(defun lj-server-rem (server property) + "Remove SERVER's PROPERTY." + (let ((server-hash (gethash server (lj-acct-hash)))) + (when server-hash + (remhash property server-hash)))) + +(defun lj-user-get (server username property) + "Fetch SERVER's value of USERNAME's PROPERTY." + (let ((user-hash (lj-server-get server username))) + (when user-hash + (gethash property user-hash)))) + +(defun lj-user-put (server username property value) + "Set SERVER's value of USERNAME's PROPERTY to VALUE." + (let ((user-hash (lj-server-get server username))) + (unless user-hash + (setq user-hash (make-hash-table :test 'equal)) + (lj-server-put server username user-hash)) + (puthash property value user-hash))) + +(defun lj-user-rem (server username property) + "Remove SERVER's USERNAME's PROPERTY." + (let ((user-hash (lj-server-get server username))) + (when user-hash + (remhash property user-hash)))) + +;; serialization / deserialization routines + +(defun lj-hash-from-alist (alist) + "Return a new hash table with the same mappings as in ALIST." + (let ((hash (make-hash-table :test 'equal))) + (mapcar (lambda (element) + (puthash (car element) (cdr element) hash)) + alist) + hash)) + +(defun lj-alist-from-hash (hash) + "Return a new alist with the same mapping as in HASH." + (let ((alist '())) + (maphash (lambda (k v) + (push (cons k v) alist)) + hash) + alist)) + +;; loading and saving cache + +(defun lj-cache-file (&optional filename) + "Return the absolute path to FILENAME. +If FILENAME is nil, returns the absolute path to the file named +\"cache\" in `lj-cache-dir'." + (if filename + (expand-file-name filename) + (expand-file-name "cache" lj-cache-dir))) + +(defun lj-cache-load (&optional filename) + "Load server and user information out of cache FILENAME. +We use our default cache location if FILENAME is nil." + (setq filename (lj-cache-file filename)) + (when (file-readable-p filename) + (with-temp-buffer + (insert-file-contents filename) + (eval-buffer)))) + +(defvar lj-cache-format 1 + "Version of the cache file format.") + +(defun lj-cache-save-forms () + "Return Lisp forms which would restore this ljupdate config if evalled." + (let ((forms '())) + (push '(setq lj-cache-format 1) forms) + (push '(setq lj-acct-hash (lj-make-acct-hash)) forms) + (maphash (lambda (server server-hash) + (push `(lj-server-put ,server :mood-max + ,(or (lj-server-get server :mood-max) + "0")) + forms) + (push `(lj-server-put ,server :moods + ',(lj-server-get server :moods)) + forms) + (maphash (lambda (username user-hash) + (when (stringp username) + ;; handle users + (mapc (lambda (field) + (let ((val (lj-user-get server username field))) + (when val + (push `(lj-user-put + ,server ,username ,field + ;; Conservatively quoting everything + ',val) + forms)))) + '(:name :access :pics :friends-groups)) + (let ((pass (lj-user-get server username :password))) + (when (and pass lj-cache-login-information) + (push `(lj-user-put + ,server ,username :password + ,pass) + forms))))) + server-hash)) + (lj-acct-hash)) + (nreverse forms))) + +(defun lj-make-directory (directory &optional parents modes) + "Create DIRECTORY. +If PARENTS is non-null, create any parent directories as necessary. +If MODES is null, 0700 are used." + (let ((umask (default-file-modes))) + (unwind-protect + (progn + (set-default-file-modes (or modes ?\700)) + (make-directory dir parents)) + (set-default-file-modes umask)))) + +(defun lj-cache-save (&optional filename) + "Save server and user information out to cache FILENAME. +We use our default cache location if FILENAME is nil." + (setq filename (lj-cache-file filename)) + (let ((dir (file-name-directory filename))) + (unless (file-exists-p dir) + (lj-make-directory dir t)) + (unless (file-directory-p dir) + (error "File `%s' is not a directory" dir))) + (unless (file-writable-p filename) + (error "Unable to write to `%s'" filename)) + (find-file filename nil) + (delete-region (point-min) (point-max)) + (insert ";; -*- emacs-lisp -*-\n" + ";; ljupdate configuration cache file\n") + (let ((standard-output (current-buffer))) + (mapc (lambda (form) + (prin1 form) + (terpri)) + (lj-cache-save-forms))) + (save-buffer) + (kill-buffer (current-buffer))) + +(add-hook 'kill-emacs-hook 'lj-cache-save) + +(provide 'lj-acct) +;;; lj-acct.el ends here hunk ./site-lisp/lj-compat.el 1 +;;; lj-compat.el --- Cross-Emacsen compatibility code for ljupdate + +;; Copyright (C) 2002, 2003, 2004, 2005 Edward O'Connor + +;; Author: Edward O'Connor +;; Keywords: convenience + +;; This file is part of ljupdate, a LiveJournal client for Emacs. + +;; ljupdate is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or +;; {at your option} any later version. + +;; ljupdate 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 +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING, or type `C-h C-c'. If +;; not, write to the Free Software Foundation at this address: + +;; Free Software Foundation +;; 51 Franklin Street, Fifth Floor +;; Boston, MA 02110-1301 +;; USA + +;;; Commentary: +;; + +;;; History: +;; + +;;; Code: + +(require 'cl) + +;; This should probably be less of a hack. +(defvar lj-coding-system (find-if 'coding-system-p '(utf-8 iso-8859-1)) + "Coding system for use when talking to LiveJournal.") + +(if (fboundp 'warn) + (defalias 'lj-warn 'warn) + (defalias 'lj-warn 'message)) + +(provide 'lj-compat) +;;; lj-compat.el ends here hunk ./site-lisp/lj-compose.el 1 +;;; lj-compose.el --- post composition for ljupdate + +;; Copyright (C) 2002, 2003, 2004, 2005 Edward O'Connor + +;; Author: Edward O'Connor +;; Keywords: convenience + +;; This file is part of ljupdate, a LiveJournal client for Emacs. + +;; ljupdate is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or +;; {at your option} any later version. + +;; ljupdate 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 +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING, or type `C-h C-c'. If +;; not, write to the Free Software Foundation at this address: + +;; Free Software Foundation +;; 51 Franklin Street, Fifth Floor +;; Boston, MA 02110-1301 +;; USA + +;;; Commentary: +;; + +;;; History: +;; + +;;; Code: + +(require 'cl) +(require 'message) +(require 'sendmail) + +(require 'lj-custom) +(require 'lj-acct) +(require 'lj-compat) +(require 'lj-fill) +(require 'lj-pcomplete) +(require 'lj-protocol) +(require 'lj-login) +(require 'lj-util) + +(eval-when-compile + ;; for `viper-change-state' + (require 'viper-cmd) + ;; from viper-init.el + (defvar viper-current-state) + ;; from viper.el + (defvar viper-mode)) + +;;; Utilities + +(defun lj-compose-fetch-field (field) + "Return this buffer's value of FIELD." + (save-excursion + (save-restriction + (widen) + (message-narrow-to-headers) + (message-fetch-field field)))) + +(defun lj-this-header () + "Return the header of line at point." + (save-excursion + (beginning-of-line) + (when (looking-at "\\([^:]+\\)[:]") + (match-string 1)))) + +(defun lj-this-server () + "Return the current value of the Server header." + (lj-compose-fetch-field "Server")) + +(defun lj-this-user () + "Return the current value of the User header." + (lj-compose-fetch-field "User")) + +;;; Code for submitting this post to LiveJournal. + +(defun lj-compose-prepare-body () + "Massage this buffer's body for submittal to LiveJournal and return as string." + (save-excursion + (save-restriction + (widen) + (message-goto-body) + (narrow-to-region (point) (point-max)) + (run-hooks 'lj-compose-pre-prepare-body-hook) + (funcall lj-fill-function) + (run-hooks 'lj-compose-post-prepare-body-hook) + (buffer-substring-no-properties (point-min) (point-max))))) + +(defun lj-compose-submit () + "Submit this entry to the server." + (interactive) + (let* ((buf (current-buffer)) + ;; The text of the entry. + (event (lj-compose-prepare-body)) + + ;; Some convenience variables for oft-used headers + (server (lj-compose-fetch-field "Server")) + (user (lj-compose-fetch-field "User")) + + ;; The current time + (time (split-string (format-time-string "%Y:%m:%d:%H:%M") "[:]")) + (year (pop time)) + (month (pop time)) + (day (pop time)) + (hour (pop time)) + (minute (pop time)) + + ;; LJ Authentication information + challenge + + ;; The actual request packet, and the response we receive from + ;; the server. + (request (list '("mode" . "postevent") + '("auth_method" . "challenge") + '("ver" . "1") + (cons "year" year) + (cons "mon" month) + (cons "day" day) + (cons "hour" hour) + (cons "min" minute) + (cons "event" event)))) + + ;; Build up the request packet. + (add-to-list 'request (cons "user" user)) + + (let ((subject (lj-compose-fetch-field "Subject"))) + (when subject + (add-to-list 'request (cons "subject" subject)))) + + ;; FIXME: use moodid if available + (let ((mood (lj-compose-fetch-field "Mood"))) + (when mood + (add-to-list 'request (cons "prop_current_mood" mood)))) + + (let ((location (lj-compose-fetch-field "Location"))) + (when location + (add-to-list 'request (cons "prop_current_location" location)))) + + (let ((tags (lj-compose-fetch-field "Tags"))) + (when tags + (add-to-list 'request (cons "prop_taglist" tags)))) + + (let ((music (lj-compose-fetch-field "Music"))) + (when music + (add-to-list 'request (cons "prop_current_music" music)))) + + (let ((community (lj-compose-fetch-field "Community"))) + (when community + (add-to-list 'request (cons "usejournal" community)))) + + (let ((picture (lj-compose-fetch-field "Picture"))) + (when picture + (add-to-list 'request (cons "prop_picture_keyword" picture)))) + + (let ((comments (lj-compose-fetch-field "Allow-Comments"))) + (when (and comments (string-match "[Nn][Oo]" comments)) + (add-to-list 'request '("prop_opt_nocomments" . "1")))) + + (let ((email (lj-compose-fetch-field "Receive-Mail-Notification"))) + (when (and email (string-match "[Nn][Oo]" email)) + (add-to-list 'request '("prop_opt_noemail" . "1")))) + + (let* ((access (lj-compose-fetch-field "Access")) + (friends-group-number + (cdr (assoc access (lj-user-get server user :friends-groups))))) + (if (stringp access) + (cond ((string-match "public" access) + (add-to-list 'request '("security" . "public"))) + ((string-match "private" access) + (add-to-list 'request '("security" . "private"))) + ((string-match "friends" access) + (add-to-list 'request '("allowmask" . "1")) + (add-to-list 'request '("security" . "usemask"))) + (friends-group-number + (add-to-list 'request (cons "allowmask" + (lj-exp2 friends-group-number))) + (add-to-list 'request '("security" . "usemask"))) + (t + (lj-warn + "Unable to understand Access: %s; presuming private." + access) + (add-to-list 'request '("security" . "private")))) + (add-to-list 'request '("security" . "public")))) + + ;; Actually talk to the LJ server. + (message "Connecting to `%s' as `%s'. Please wait." server user) + (setq challenge (lj-getchallenge server)) + + (add-to-list 'request (cons "auth_challenge" challenge)) + (add-to-list 'request + (cons "auth_response" + (lj-md5 (concat challenge (lj-password server user))))) + + (message "Submitting to `%s' as `%s'. Please wait." server user) + + (let ((response (lj-protocol-send-request server request))) + (set-buffer buf) ; return to the *LiveJournal* buffer + (if (and (hash-table-p response) + (string= (gethash "success" response) "OK")) + (progn + (set-buffer-modified-p nil) + (message "Successfully posted as %s." (gethash "url" response)) + t) + (let ((errmsg (gethash "errmsg" response))) + (if errmsg + (message "Posting to %s failed: %s" server errmsg) + (message "Posting to %s failed!" server))) + nil)))) + +(defun lj-compose-submit-then-exit () + "Submit this entry to the server, and exit if successful." + (interactive) + (when (lj-compose-submit) + (quit-window))) + +;;; Code for handling the separator between headers and body. + +(defvar lj-compose-header/body-marker nil + "The marker between the lj message's header and body sections. +Anything before this marker will be in `message-mode' and anything below +in `html-mode'.") +(make-variable-buffer-local 'lj-compose-header/body-marker) +(put 'lj-compose-header/body-marker 'permanent-local t) + +(defun lj-compose-find-separator () + "If non-null, the position of mail-header-separator in this buffer." + (save-excursion + (goto-char (point-min)) + (re-search-forward (regexp-quote mail-header-separator) nil t))) + +(defun lj-compose-propertize-separator (&optional pos) + "Puts the `mail-header-separator' property on the header separator." + (save-excursion + (goto-char (or pos (lj-compose-find-separator))) + (let ((beg (line-beginning-position)) + (end (line-end-position))) + (put-text-property beg end 'category 'mail-header-separator)))) + +(defun lj-compose-mark-separator (&optional pos) + "Initialize `lj-compose-header/body-marker' " + (set (make-local-variable 'lj-compose-header/body-marker) + (let ((marker (make-marker)) + (sep-pos (or pos (lj-compose-find-separator)))) + (lj-compose-propertize-separator sep-pos) + (set-marker marker sep-pos) + marker))) + +;;; Major modes for editing LiveJournal posts. + +(defun lj-compose-check-mode () + "Ensure we're using the correct major mode for this part of the buffer." + (let ((there (if (and (boundp 'lj-compose-header/body-marker) + (markerp lj-compose-header/body-marker)) + (marker-position lj-compose-header/body-marker) + (lj-compose-mark-separator))) + (here (point)) + (lj-saved-viper-state (and (boundp 'viper-current-state) + viper-current-state))) + (cond ((and (< here there) + (not (eq major-mode 'lj-compose-header-mode))) + (lj-compose-header-mode)) + ((and (> here there) + (not (eq major-mode 'lj-compose-body-mode))) + (lj-compose-body-mode))) + (when (and (boundp 'viper-mode) viper-mode) + (viper-change-state lj-saved-viper-state)))) + +(define-derived-mode lj-compose-header-mode message-mode "LJ:H" + (mml-mode -1) + (set (make-local-variable 'message-auto-save-directory) "~/.ljupdate/drafts") + (lj-pcomplete-setup) + (define-key lj-compose-header-mode-map "\t" 'pcomplete) + (run-hooks 'lj-compose-common-hook) + (add-hook 'post-command-hook 'lj-compose-check-mode nil t)) + +(define-derived-mode lj-compose-body-mode html-mode "LJ:B" + (run-hooks 'lj-compose-common-hook) + (add-hook 'post-command-hook 'lj-compose-check-mode nil t)) + +;;;###autoload +(defun lj-compose-mode () + "Major mode for editing LiveJournal posts." + (lj-compose-mark-separator) + (lj-compose-check-mode)) + +;;;###autoload +(add-to-list 'auto-mode-alist '("\\.lj\\'" . lj-compose-mode)) + +;;; Key bindings. + +(define-key lj-compose-header-mode-map (kbd "C-c C-s") 'lj-compose-submit) +(define-key lj-compose-body-mode-map (kbd "C-c C-s") 'lj-compose-submit) + +(define-key lj-compose-header-mode-map (kbd "C-c C-c") 'lj-compose-submit-then-exit) +(define-key lj-compose-body-mode-map (kbd "C-c C-c") 'lj-compose-submit-then-exit) + +;; (define-key lj-compose-body-mode-map (kbd "C-c ") 'lj-complete-body) + +;; Ensure that unwanted Message bindings get shadowed. +;; I should probably do this in a nicer way. +(mapc (lambda (key) + (define-key lj-compose-header-mode-map key 'undefined)) + (list (kbd "C-c C-a") (kbd "C-c C-e") (kbd "C-c C-f a") + (kbd "C-c C-f s") (kbd "C-c C-f t") (kbd "C-c C-f w") + (kbd "C-c C-f x") (kbd "C-c C-f C-a") (kbd "C-c C-f C-b") + (kbd "C-c C-f C-c") (kbd "C-c C-f C-d") (kbd "C-c C-f C-f") + (kbd "C-c C-f C-k") (kbd "C-c C-f C-n") (kbd "C-c C-f C-o") + (kbd "C-c C-f C-r") (kbd "C-c C-f C-t") (kbd "C-c C-f C-u") + (kbd "C-c C-f ") ; (kbd "C-c C-f ") + (kbd "C-c C-j") (kbd "C-c C-l") (kbd "C-c C-n") + (kbd "C-c C-q") (kbd "C-c C-r") (kbd "C-c C-t") + (kbd "C-c C-u") (kbd "C-c C-v") (kbd "C-c C-w") + (kbd "C-c C-y") (kbd "C-c C-z") (kbd "C-c f") + (kbd "C-c h") (kbd "C-c m") (kbd "C-c n") + (kbd "C-c r") (kbd "C-c y") ; (kbd "C-c ") + )) + +;; Ensure that unwanted HTML mode bindings get shadowed. +(mapc (lambda (key) + (define-key lj-compose-body-mode-map key 'undefined)) + (list (kbd "C-c C-v"))) + +;;; `lj-compose' is the major interactive entry point into this file. + +;;;###autoload +(defun lj-compose () + "Compose a new LiveJournal post." + (interactive) + + ;; Create the composition buffer. + (switch-to-buffer (get-buffer-create "*LiveJournal*")) + + (unless (buffer-modified-p) + (delete-region (point-min) (point-max)) + (lj-compose-populate-buffer) + (goto-char (point-min)) + (lj-compose-header-mode) + (if (or lj-last-username lj-default-username) + (message-position-on-field "Subject") + (message-position-on-field "User")))) + +(defun lj-compose-populate-buffer (&optional values) + "Populate the current buffer as a LiveJournal post." + ;; Insert the essential headers. + (unless (hash-table-p values) + (setq values (make-hash-table))) + (insert "Server: " (or (gethash :server values) + lj-last-server + lj-default-server + "www.livejournal.com") + "\n" + + "User: " (or (gethash :username values) + lj-last-username + lj-default-username + "") + "\n" + + "Community: " (or (gethash :community values) "") "\n" + "Mood: " (or (gethash :mood values) "") "\n" + "Location: " (or (gethash :location values) "") "\n" + "Access: " (or (gethash :access values) "public") "\n" + "Subject: " (or (gethash :subject values) "") "\n" + "Tags: " (or (gethash :tags values) "") "\n") + + ;; Give the user an opportunity to add additional headers to the + ;; buffer. + (insert lj-default-headers) + (run-hooks 'lj-compose-init-headers-hook) + + (insert mail-header-separator) + (lj-compose-mark-separator) + (insert "\n") + + (insert (gethash :body values "")) + + ;; Give the user an opportunity to pre-populate the buffer in some + ;; way. + (run-hooks 'lj-compose-init-body-hook) + + ;; The user hasn't actually done anything to this buffer, so it + ;; shouldn't be marked as modified. + (set-buffer-modified-p nil)) + +(provide 'lj-compose) + +;;; lj-compose.el ends here hunk ./site-lisp/lj-custom.el 1 +;;; lj-custom.el --- Custom declarations for ljupdate + +;; Copyright (C) 2002, 2003, 2004, 2005 Edward O'Connor + +;; Author: Edward O'Connor +;; Keywords: convenience + +;; This file is part of ljupdate, a LiveJournal client for Emacs. + +;; ljupdate is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or +;; {at your option} any later version. + +;; ljupdate 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 +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING, or type `C-h C-c'. If +;; not, write to the Free Software Foundation at this address: + +;; Free Software Foundation +;; 51 Franklin Street, Fifth Floor +;; Boston, MA 02110-1301 +;; USA + +;;; Commentary: +;; + +;;; History: +;; + +;;; Code: + +(defgroup ljupdate nil + "Emacs LiveJournal client." + :group 'processes + :prefix "lj-" + :link '(url-link "http://edward.oconnor.cx/ljupdate/") + :link '(url-link "http://www.livejournal.com/community/ljupdate/")) + +(defcustom lj-cache-dir "~/.ljupdate" + "Directory in which ljupdate saves cached server information." + :group 'ljupdate + :type '(directory)) + +(defcustom lj-cache-login-information nil + "If non-null, ljupdate will cache the md5 hashes of your paswords. +You might enable this if you don't want to have to log in each time. +However, be warned that ljupdate won't try to update its other cached +information (your friends groups, your journal access list, etc.) if +this is enabled." + :group 'ljupdate + :type '(boolean)) + +(defcustom lj-fill-function 'lj-fill-by-paragraph + "We use this function to fill your post contents before sending. +When this function is called, the buffer is narrowed to the body. +Set this to `ignore' to send article contents to the server unaltered. +See `lj-fill.el' for several possible values, or write your own!" + :group 'ljupdate + :type '(choice (const :tag "Raw (don't fill)" ignore) + (const :tag "Default (by paragraph)" lj-fill-by-paragraph) + (const :tag "Pipe through shell command" + lj-fill-by-shell-command) + (function))) + +(defcustom lj-fill-by-shell-command-command "cat" + "Shell command to pipe your LiveJournal post through. + +Your post will be filtered through this command. The output is what will +actually be posted to your LiveJournal. + +This only has an effect when you use \"Pipe through shell command\" as your +Lj Fill Function, above." + :group 'ljupdate + :type '(string)) + +(defcustom lj-default-server "www.livejournal.com" + "LiveJournal server to use by default in various contexts." + :group 'ljupdate + :type '(string)) + +(defcustom lj-default-username nil + "Username to use by default in various contexts." + :group 'ljupdate + :type '(choice string (const nil))) + +(defcustom lj-compose-common-hook nil + "Normal hook run by `lj-compose-header-mode' and `lj-compose-body-mode'. +Note that this hook will be run each time your cursor moves from the headers +to the body and vice-versa." + :group 'ljupdate + :type 'hook) + +(defcustom lj-compose-init-headers-hook nil + "Hook to be run after headers have been added to a composition buffer. +Use this hook to insert additional headers into the buffer. The point is +left after the end of the headers." + :group 'ljupdate + :type 'hook) + +(defcustom lj-compose-init-body-hook nil + "Hook to be run after a new composition buffer has been initialized. +Use this hook to insert initial contents into the body of the post. The +point is left at the beginning of the body." + :group 'ljupdate + :type 'hook) + +(defcustom lj-compose-pre-prepare-body-hook nil + "Hook run by `lj-compose-prepare-body' before running `lj-fill-function'. +The buffer is narrowed to the body when this hook is run." + :group 'ljupdate + :type 'hook) + +(defcustom lj-compose-post-prepare-body-hook nil + "Hook run by `lj-compose-prepare-body' after running `lj-fill-function'. +The buffer is narrowed to the body when this hook is run." + :group 'ljupdate + :type 'hook) + +(defcustom lj-default-headers "" + "*A string containing header lines to be inserted in outgoing messages. +It is inserted before you edit the message, so you can edit or delete +these lines." + :group 'ljupdate + :type 'string) + +;; FIXME: use +(defcustom lj-default-access-level "public" + "Current possible values are ``public'', ``private'', and ``friends''." + :group 'ljupdate + :type '(choice (const :tag "Public (anyone)" "public") + (const :tag "Private (you only)" "private") + (const :tag "Friends-only" "friends"))) + +;; FIXME: use +(defcustom lj-allow-comments "yes" + "Whether or not comments on your posts are allowed by default." + :group 'ljupdate + :type '(choice (const :tag "Allow comments" "yes") + (const :tag "Disallow comments" "no"))) + +;; FIXME: use +(defcustom lj-default-mail-notification "yes" + "Non-nil if you should receive comment notification email by default." + :group 'ljupdate + :type '(choice (const :tag "Receive Mail Notification" "yes") + (const :tag "Do Not Receive Mail Notification" "no"))) + +(provide 'lj-custom) + +;;; lj-custom.el ends here hunk ./site-lisp/lj-fill.el 1 +;;; lj-fill.el --- various filling methods for livejournal posts + +;; Copyright (C) 2002, 2003, 2004, 2005 Edward O'Connor + +;; Author: Edward O'Connor +;; Keywords: convenience + +;; This file is part of ljupdate, a LiveJournal client for Emacs. + +;; ljupdate is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or +;; {at your option} any later version. + +;; ljupdate 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 +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING, or type `C-h C-c'. If +;; not, write to the Free Software Foundation at this address: + +;; Free Software Foundation +;; 51 Franklin Street, Fifth Floor +;; Boston, MA 02110-1301 +;; USA + +;;; Commentary: +;; +;; The intent is for several different filling methods to live here. +;; Currently, there are only two recommended values of +;; `lj-fill-function': `lj-fill-by-paragraph' and `ignore'. +;; Read the `lj-fill-function' doc string for more. + +;;; History: +;; + +;;; Code: + +(require 'lj-custom) + +(defvar lj-fill-by-paragraph-fill-column 10000 + "*Value to be used for `fill-column' by `lj-fill-by-paragraph'.") + +(defvar lj-fill-flush-empty-lines-flag t + "*Non-nil means that `lj-fill-by-paragraph' will remove blank lines.") + +(defvar lj-fill-inter-paragraph-newline-count 2 + "*How many newlines to use in between paragraphs. +Yuo probably want this to be at least 1.") + +(defun lj-fill-by-paragraph () + "Fills your LiveJournal post while assuming you wrote text with auto fill. + +Assumes that consecutive non-blank lines are paragraphs, unfills them, +and kills any extra blank lines. If your posts are predominately text, +with little to no markup, this is probably the behavior you will like. + +This is like the default filling behavior of the old ljupdate code. If +you didn't like it then, you won't like it now. You may want to fiddle +with the values of `lj-fill-by-paragraph-fill-column', +`lj-fill-flush-empty-lines-flag', and/or +`lj-fill-inter-paragraph-newline-count' in order to produce the sort of +behavior you'd like this function to exhibit. Or, you may change the +value of `lj-fill-function' to a function more to your liking (e.g. +`ignore')." + ;; Fill paragraphs + (goto-char (point-min)) + (let ((fill-column lj-fill-by-paragraph-fill-column)) + (fill-paragraph nil) + (while (zerop (forward-paragraph 1)) + (fill-paragraph nil))) + ;; Kill blank lines + (when lj-fill-flush-empty-lines-flag + (flush-lines "^$" (point-min) (point-max))) + ;; Restore paragraph separation + (goto-char (point-min)) + (let ((newlines (make-string lj-fill-inter-paragraph-newline-count ?\n))) + (while (search-forward "\n" nil t) + (replace-match newlines)))) + +(defun lj-fill-by-shell-command () + "Filters your LiveJournal post through a shell command." + (shell-command-on-region (point-min) (point-max) + lj-fill-by-shell-command-command t)) + + +(provide 'lj-fill) +;;; lj-fill.el ends here hunk ./site-lisp/lj-login.el 1 +;;; lj-login.el --- lj protocol login support for ljupdate + +;; Copyright (C) 2002, 2003, 2004, 2005 Edward O'Connor + +;; Author: Edward O'Connor +;; Keywords: convenience + +;; This file is part of ljupdate, a LiveJournal client for Emacs. + +;; ljupdate is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or +;; {at your option} any later version. + +;; ljupdate 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 +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING, or type `C-h C-c'. If +;; not, write to the Free Software Foundation at this address: + +;; Free Software Foundation +;; 51 Franklin Street, Fifth Floor +;; Boston, MA 02110-1301 +;; USA + +;;; Commentary: +;; + +;;; History: +;; + +;;; Code: + +(require 'cl) + +(require 'lj-compat) +(require 'lj-custom) +(require 'lj-acct) +(require 'lj-protocol) +(require 'lj-util) + +;; from ljupdate.el +(eval-when-compile (defvar lj-client-version)) + +(defvar lj-last-server nil + "The last LJ server we used during this Emacs session.") + +(defvar lj-last-username nil + "The last LJ username we used during this Emacs session.") + +(defun lj-process-login-response (server username info) + "Process SERVER's login information returned when we logged in as USERNAME. +Argument INFO is the bundle of values returned by the server." + + (let ((name (gethash "name" info)) + (access-count (lj-number (gethash "access_count" info 0))) + (pickw-count (lj-number (gethash "pickw_count" info 0))) + (frgrp-maxnum (lj-number (gethash "frgrp_maxnum" info 0))) + (mood-count (lj-number (gethash "mood_count" info 0))) + (message (gethash "message" info))) + + (when message + (message "%s" message) + (sit-for 2)) + + (when name + (lj-user-put server username :name name)) + + (let ((access-list '())) + (dotimes (access-num access-count) + (let ((name (gethash (format "access_%d" (1+ access-num)) info))) + (push name access-list))) + (lj-user-put server username :access access-list)) + + (let ((pickw-list '())) + (dotimes (pickw-num pickw-count) + (let ((name (gethash (format "pickw_%d" (1+ pickw-num)) info))) + (push name pickw-list))) + (lj-user-put server username :pics pickw-list)) + + (let ((frgrp-alist '())) + (dotimes (frgrp-num frgrp-maxnum) + (let ((name (gethash (format "frgrp_%d_name" (1+ frgrp-num)) info)) + (sort (gethash (format "frgrp_%d_sortorder" (1+ frgrp-num)) info))) + (when name + (push (cons name (1+ frgrp-num)) frgrp-alist)))) + (lj-user-put server username :friends-groups frgrp-alist)) + + (let ((mood-max (or (lj-number (lj-server-get server :mood-max)) 0)) + (mood-alist (lj-server-get server :moods))) + (dotimes (mood-num mood-count) + (let ((name (gethash (format "mood_%d_name" (1+ mood-num)) info)) + (id (lj-number (or (gethash (format "mood_%d_id" (1+ mood-num)) info) + 0)))) + (when (> id mood-max) + (lj-server-put server :mood-max id)) + (push (cons name id) mood-alist))) + (lj-server-put server :moods mood-alist)))) + +(defun lj-attempt-login-once (server username password) + "Try to log in to SERVER with USERNAME and PASSWORD. +Returns a boolean indicating whether or not the login attempt succeeded. +PASSWORD is the downcased MD5sum of the user's password." + (message "Logging into `%s' as `%s'. Please wait." server username) + + (let ((challenge (lj-getchallenge server))) + (let* ((auth-response (lj-md5 (concat challenge password))) + (response + (lj-protocol-send-request + server + `(("mode" . "login") + ("ver" . ,(if (eq lj-coding-system 'utf-8) + "1" + "0")) + ("clientversion" . ,lj-client-version) + ("user" . ,username) + ("auth_method" . "challenge") + ("auth_challenge" . ,challenge) + ("auth_response" . ,auth-response) + ("getmoods" . ,(format "%s" + (or (lj-server-get server :mood-max) + 0))) + ("getpickws" . "1"))))) ; get userpics + (if (hash-table-p response) + (cond ((string= (gethash "success" response) "OK") + (lj-process-login-response server username response) + t) + ((string= (gethash "success" response) "FAIL") + (message "Logging into `%s' failed; error message is `%s'." + server (gethash "errmsg" response)) + nil) + (t + (message + "Logging into `%s' failed (empty response); please try again later." + server))) + (message "Logging into `%s' failed (null response); please try again later." + server) + nil)))) + +(defun lj-attempt-login (server username explicit-login) + "Attempt to log into SERVER (as USERNAME) once. + +If EXPLICIT-LOGIN is non-nil, the user has requested this login +explicitly, so we message useful feedback to the echo area." + (let ((tries 0) + (logged-in nil) + (password nil)) + (while (and (not logged-in) (< tries 3)) + (setq password + (lj-md5 (read-passwd + (format "Password for %s@%s: " username server)))) + (setq tries (+ tries 1) + logged-in (lj-attempt-login-once server username password))) + (if logged-in + (progn + (setq lj-last-username username + lj-last-server server) + (lj-user-put server username :password password) + (when explicit-login + (message "Successfully logged in as %s@%s." username server)) + password) + (when explicit-login + (message "Login failure for %s@%s." username server) + nil)))) + +(defun lj-read-server () + "Read a server name from the user." + (let ((guess (or lj-last-server lj-default-server "www.livejournal.com"))) + (completing-read "Server: " + (mapcar (lambda (item) (cons item item)) + (lj-servers)) + nil nil guess nil guess nil))) + +(defun lj-read-username (&optional server) + "Read a username (of SERVER, if supplied) from the user." + (completing-read "Username: " + (mapcar (lambda (item) (cons item item)) + (lj-users (or server + lj-last-server + lj-default-server))) + nil nil lj-default-username nil lj-default-username nil)) + +(defun lj-read-server-username-pair () + "Read a server and a username at that server from the user." + (let ((server (lj-read-server))) + (list server (lj-read-username server)))) + +;;;###autoload +(defun lj-login (server username) + "Logs into SERVER as USERNAME, and return the md5sum of USERNAME's password." + (interactive (lj-read-server-username-pair)) + (or (lj-user-get server username :password) + (lj-attempt-login server username (interactive-p)) + (error "Unable to log into %s as %s" server username))) + +;;;###autoload +(defun lj-logout (server username) + "Logs off of SERVER (as USERNAME)." + (interactive (lj-read-server-username-pair)) + (lj-user-rem server username :password)) + +;; Internally, I call this to get the password for the given user@host. +;; So let's make code calling this easier to read. +;;;###autoload +(defalias 'lj-password 'lj-login) + +(provide 'lj-login) + +;;; lj-login.el ends here hunk ./site-lisp/lj-maint.el 1 +;;; lj-maint.el --- compilation and maintenance hacks for ljupdate + +;; Copyright (C) 2002, 2003, 2004, 2005 Edward O'Connor + +;; Author: Edward O'Connor +;; Keywords: convenience + +;; This file is part of ljupdate, a LiveJournal client for Emacs. + +;; ljupdate is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or +;; {at your option} any later version. + +;; ljupdate 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 +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING, or type `C-h C-c'. If +;; not, write to the Free Software Foundation at this address: + +;; Free Software Foundation +;; 51 Franklin Street, Fifth Floor +;; Boston, MA 02110-1301 +;; USA + +;;; Commentary: +;; + +;;; History: +;; + +;;; Code: + +;; `load-path' frobbing; used for compiling + +(add-to-list 'load-path default-directory) +(mapc (lambda (dir) (add-to-list 'load-path dir)) + (parse-colon-path (getenv "LOAD_PATH"))) + +;; autoload generation; used to create `ljupdate.el' + +(defvar generated-autoload-file) +(defvar command-line-args-left) +(defun lj-generate-autoloads () + "Generate autoloads for ljupdate." + (interactive) + (require 'autoload) + (setq generated-autoload-file + (expand-file-name (car command-line-args-left) default-directory)) + (setq command-line-args-left (cdr command-line-args-left)) + (batch-update-autoloads)) + +(defun lj-debug-response (response) + "Dump RESPONSE into a buffer so we can look at it." + (switch-to-buffer (get-buffer-create "*LJ DEBUG*")) + (maphash (lambda (k v) (insert (format "%s\n%s\n" k v))) response)) + +(provide 'lj-maint) + +;;; lj-maint.el ends here hunk ./site-lisp/lj-pcomplete.el 1 +;;; lj-pcomplete.el --- programmable completion for ljupdate composition buffers + +;; Copyright (C) 2002, 2003, 2004, 2005 Edward O'Connor + +;; Author: Edward O'Connor +;; Keywords: convenience + +;; This file is part of ljupdate, a LiveJournal client for Emacs. + +;; ljupdate is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or +;; {at your option} any later version. + +;; ljupdate 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 +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING, or type `C-h C-c'. If +;; not, write to the Free Software Foundation at this address: + +;; Free Software Foundation +;; 51 Franklin Street, Fifth Floor +;; Boston, MA 02110-1301 +;; USA + +;;; Commentary: +;; + +;;; History: +;; + +;;; Code: + +(require 'pcomplete) + +(defun lj-pcomplete-setup () + "Configure this buffer for programmable completion." + (set (make-local-variable 'pcomplete-termination-string) "") + (set (make-local-variable 'pcomplete-ignore-case) t) + (set (make-local-variable 'pcomplete-use-paring) nil) + (set (make-local-variable 'pcomplete-parse-arguments-function) + 'lj-pcomplete-parse-header-arguments) + (set (make-local-variable 'pcomplete-command-name-function) + 'lj-this-header)) + +;; header completion + +(defun pcomplete/lj-compose-header-mode/Subject () + "Attempt to complete the Subject header." + (pcomplete-here nil)) + +(defun pcomplete/lj-compose-header-mode/Mood () + "Attempt to complete the Mood header." + (pcomplete-here (sort (mapcar 'car (lj-server-get (lj-this-server) :moods)) + 'string-lessp) + nil nil t)) + +(defun pcomplete/lj-compose-header-mode/Server () + "Attempt to complete the Server header." + (pcomplete-here (sort (lj-servers) 'string-lessp) + nil nil t)) + +(defun pcomplete/lj-compose-header-mode/User () + "Attempt to complete the User header." + (pcomplete-here (sort (lj-users (lj-this-server)) 'string-lessp) + nil nil t)) + +(defun pcomplete/lj-compose-header-mode/Community () + "Attempt to complete the Community header." + (pcomplete-here (sort (copy-list (lj-user-get (lj-this-server) + (lj-this-user) + :access)) + 'string-lessp) + nil nil t)) + +(defun pcomplete/lj-compose-header-mode/Access () + "Attempt to complete the Access header." + (pcomplete-here (sort + (append + (list "public" "private" "friends") + (mapcar 'car + (lj-user-get (lj-this-server) + (lj-this-user) + :friends-groups)) + ) + 'string-lessp) + nil nil t)) + +;; pcomplete support code + +(defun lj-pcomplete-parse-header-arguments () + "Return a list of parsed whitespace-separated arguments. +These are the words from the beginning of the line up to where point is +right now." + (let* ((start (save-excursion (beginning-of-line) (point))) + (end (point)) + args beginnings) + (save-excursion + (if (< (skip-chars-backward " \t\n" start) 0) + (setq args '("") + beginnings (list end))) + (setq end (point)) + (while (< (skip-chars-backward "^ \t\n" start) 0) + (setq beginnings (cons (point) beginnings) + args (cons (buffer-substring-no-properties + (point) end) + args)) + (skip-chars-backward " \t\n" start) + (setq end (point)))) + (cons args beginnings))) + +(provide 'lj-pcomplete) +;;; lj-pcomplete.el ends here hunk ./site-lisp/lj-protocol.el 1 +;;; lj-protocol.el --- "flat" protocol support for ljupdate + +;; Copyright (C) 2002, 2003, 2004, 2005 Edward O'Connor + +;; Author: Edward O'Connor +;; Keywords: convenience + +;; This file is part of ljupdate, a LiveJournal client for Emacs. + +;; ljupdate is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or +;; {at your option} any later version. + +;; ljupdate 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 +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING, or type `C-h C-c'. If +;; not, write to the Free Software Foundation at this address: + +;; Free Software Foundation +;; 51 Franklin Street, Fifth Floor +;; Boston, MA 02110-1301 +;; USA + +;;; Commentary: +;; + +;;; History: +;; + +;;; Code: + +(require 'http-post) + +(require 'lj-compat) +(require 'lj-util) + +(defun lj-protocol-server-url (hostname) + "Return the URL to the LJ protocol's \"flat\" interface on HOSTNAME." + (concat "http://" hostname "/interface/flat")) + +(defsubst lj-this-line () + "Return a string containing the current line in the current buffer." + (buffer-substring-no-properties (line-beginning-position) + (line-end-position))) + +(defun lj-protocol-send-request (server request) + "Send to SERVER a REQUEST via the LiveJournal protocol. +If the request succeeds, this returns a hash table whose keys and values +contain the server's response. Or, if the request was unsuccessful, this +returns nil ." + (let ((process (http-post (lj-protocol-server-url server) request + lj-coding-system '(("Connection" . "close")) + 'ignore 1.0 nil " *LiveJournal response*"))) + (while (accept-process-output process)) + (with-current-buffer (process-buffer process) + ;; (if (and (stringp http-status-code) (= http-status-code 200)) ; HTTP 200 OK + (let ((response (make-hash-table :test 'equal)) + (have-frobbed nil)) + (decode-coding-region (point-min) (point-max) lj-coding-system) + (goto-char (point-min)) + (let ((on-variable-name-line t) + var) + (while (< (point) (point-max)) + (cond (on-variable-name-line (setq var (lj-this-line))) + (t + (puthash var (lj-this-line) response) + (setq have-frobbed t))) + (forward-line 1) + (setq on-variable-name-line (not on-variable-name-line)))) + (if have-frobbed + (prog1 response + (kill-buffer (current-buffer))) + (rename-buffer "*LiveJournal debug*")))))) + +(defun lj-getchallenge (server) + "Get an authentication challenge from SERVER." + (let* ((response (lj-protocol-send-request + server '(("mode" . "getchallenge")))) + (challenge (and (hash-table-p response) (gethash "challenge" response)))) + (unless (stringp challenge) + (error "Unable to connect to %s" server)) + challenge)) + +(provide 'lj-protocol) + +;;; lj-protocol.el ends here hunk ./site-lisp/lj-util.el 1 +;;; lj-util.el --- misc elisp utilities for ljupdate + +;; Copyright (C) 2002, 2003, 2004, 2005 Edward O'Connor + +;; Author: Edward O'Connor +;; Keywords: convenience + +;; This file is part of ljupdate, a LiveJournal client for Emacs. + +;; ljupdate is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or +;; {at your option} any later version. + +;; ljupdate 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 +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING, or type `C-h C-c'. If +;; not, write to the Free Software Foundation at this address: + +;; Free Software Foundation +;; 51 Franklin Street, Fifth Floor +;; Boston, MA 02110-1301 +;; USA + +;;; Commentary: +;; + +;;; History: +;; + +;;; Code: + +(require 'md5) + +(require 'lj-compat) + +(defun lj-md5 (string) + "MD5s STRING and downcases the result. +The LiveJournal server code doesn't accept upcased MD5sums. Case +sensitivity is dumb." + (downcase (md5 string nil nil lj-coding-system))) + +(defun lj-number (thing) + "Convert THING to a number, if necessary." + (cond ((numberp thing) thing) + ((stringp thing) (string-to-number thing)) + (t 0))) + +(defun lj-exp2 (n) + "Return a string representation of 2^N for 0 <= N <= 30." + (cond ((or (< n 0) (> n 30)) + (signal 'args-out-of-range n)) + ((< n 27) (number-to-string (lsh 1 n))) + ;; Emacs integers aren't 32-bit quantities, so we cheat. + ((= n 27) "134217728") + ((= n 28) "268435456") + ((= n 29) "536870912") + ((= n 30) "1073741824"))) + +(provide 'lj-util) + +;;; lj-util.el ends here hunk ./site-lisp/ljupdate.el 1 +;;; ljupdate.el --- a LiveJournal client for Emacs -*- emacs-lisp -*- + +;; Copyright (C) 2002, 2003, 2004, 2005 Edward O'Connor + +;; Author: Edward O'Connor +;; Keywords: convenience + +;; This file is part of ljupdate, a LiveJournal client for Emacs. + +;; ljupdate is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or +;; {at your option} any later version. + +;; ljupdate 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 +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING, or type `C-h C-c'. If +;; not, write to the Free Software Foundation at this address: + +;; Free Software Foundation +;; 51 Franklin Street, Fifth Floor +;; Boston, MA 02110-1301 +;; USA + +;;; Commentary: +;; + +;;; History: +;; + +;;; Code: + +(require 'lj-custom) + +(defconst lj-client-revision "12" + "The Subversion revision of your ljupdate.") + +(defun lj-client-version () + (format "%sEmacs-ljupdate/4.0.%s" + (cond ((featurep 'sxemacs) "SX") + ((featurep 'xemacs) "X") + (t "")) + ;; `lj-client-revision' might be a simple number, or it might + ;; match X:YM?S?, where X and Y are revision numbers. + (apply 'max + (mapcar 'string-to-number + (split-string lj-client-revision "[:MS]"))))) + +(defconst lj-client-version (lj-client-version) + "The client version to report to the server.") + +(provide 'ljupdate) + +;;; Generated autoloads follow (made by autoload.el). +;;; ljupdate.in ends here + +;;;### (autoloads (lj-compose lj-compose-mode) "lj-compose" "lj-compose.el" +;;;;;; (17644 46520)) +;;; Generated autoloads from lj-compose.el + +(autoload (quote lj-compose-mode) "lj-compose" "\ +Major mode for editing LiveJournal posts." nil nil) + +(add-to-list (quote auto-mode-alist) (quote ("\\.lj\\'" . lj-compose-mode))) + +(autoload (quote lj-compose) "lj-compose" "\ +Compose a new LiveJournal post." t nil) + +;;;*** + +;;;### (autoloads (lj-logout lj-login) "lj-login" "lj-login.el" (17644 +;;;;;; 46520)) +;;; Generated autoloads from lj-login.el + +(autoload (quote lj-login) "lj-login" "\ +Logs into SERVER as USERNAME, and return the md5sum of USERNAME's password." t nil) + +(autoload (quote lj-logout) "lj-login" "\ +Logs off of SERVER (as USERNAME)." t nil) + +(defalias (quote lj-password) (quote lj-login)) + +;;;*** + +;;;### (autoloads (http-get) "http-get" "http-get.el" (17644 46549)) +;;; Generated autoloads from http-get.el + +(autoload (quote http-get) "http-get" "\ +Get URL in a buffer, and return the process. +You can get the buffer associated with this process using +`process-buffer'. + +The optional HEADERS are an alist where each element has the form +\(NAME . VALUE). Both must be strings and will be passed along with +the request. + +With optional argument SENTINEL, the buffer is not shown. It is the +responsibility of the sentinel to show it, if appropriate. A sentinel +function takes two arguments, process and message. It is called when +the process is killed, for example. This is useful when specifying a +non-persistent connection. By default, connections are persistent. +Add (\"Connection\" . \"close\") to HEADERS in order to specify a +non-persistent connection. Usually you do not need to specify a +sentinel, and `ignore' is used instead, to prevent a message being +printed when the connection is closed. + +If you want to filter the content as it arrives, bind +`http-filter-pre-insert-hook' and `http-filter-post-insert-hook'. + +The optional argument VERSION specifies the HTTP version to use. It +defaults to version 1.0, such that the connection is automatically +closed when the entire document has been downloaded. This will then +call SENTINEL, if provided. If no sentinel is provided, `ignore' will +be used in order to prevent a message in the buffer when the process +is killed. + +CONTENT-TYPE is a coding system to use for the encoding of the url +param value. Its upper case print name will be used for the server. +Possible values are `iso-8859-1' or `euc-jp' and others. + +The coding system of the process is set to `binary', because we need to +distinguish between \\r and \\n. To correctly decode the text later, +use `decode-coding-region' and get the coding system to use from +`http-headers'." t nil) + +;;;*** hunk ./site-lisp/ssl.el 1 +;;; ssl.el,v --- ssl functions for Emacsen without them builtin +;; Author: William M. Perry +;; $Revision: 1.5 $ +;; Keywords: comm + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 1995, 1996 by William M. Perry +;;; Copyright (c) 1996, 97, 98, 99, 2001 Free Software Foundation, Inc. +;;; +;;; This file is part of GNU Emacs. +;;; +;;; GNU Emacs is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2, or (at your option) +;;; any later version. +;;; +;;; GNU Emacs 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 General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Emacs; see the file COPYING. If not, write to the +;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;;; Boston, MA 02111-1307, USA. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(eval-when-compile (require 'cl)) +(require 'base64) +(require 'url) ; for `url-configuration-directory' + +(defgroup ssl nil + "Support for `Secure Sockets Layer' encryption." + :group 'comm) + +(defcustom ssl-certificate-directory "~/.w3/certs/" + "*Directory in which to store CA certificates." + :group 'ssl + :type 'directory) + +(defcustom ssl-rehash-program-name "c_rehash" + "*Program to run after adding a cert to a directory . +Run with one argument, the directory name." + :group 'ssl + :type 'string) + +(defcustom ssl-view-certificate-program-name "x509" + "*The program to run to provide a human-readable view of a certificate." + :group 'ssl + :type 'string) + +(defcustom ssl-view-certificate-program-arguments '("-text" "-inform" "DER") + "*Arguments that should be passed to the certificate viewing program. +The certificate is piped to it. +Maybe a way of passing a file should be implemented" + :group 'ssl + :type '(repeat string)) + +(defcustom ssl-certificate-directory-style 'ssleay + "*Style of cert database to use, the only valid value right now is `ssleay'. +This means a directory of pem encoded certificates with hash symlinks." + :group 'ssl + :type '(choice (const :tag "SSLeay" :value ssleay) + (const :tag "OpenSSL" :value openssl))) + +(defcustom ssl-certificate-verification-policy 0 + "*How far up the certificate chain we should verify." + :group 'ssl + :type '(choice (const :tag "No verification" :value 0) + (const :tag "Verification required" :value 1) + (const :tag "Reject connection if verification fails" :value 3) + (const :tag "SSL_VERIFY_CLIENT_ONCE" :value 5))) + +(defcustom ssl-program-name "openssl" + "*The program to run in a subprocess to open an SSL connection." + :group 'ssl + :type 'string) + +(defcustom ssl-program-arguments + '("s_client" + "-quiet" + "-host" host + "-port" service + "-verify" (int-to-string ssl-certificate-verification-policy) + "-CApath" ssl-certificate-directory + ) + "*Arguments that should be passed to the program `ssl-program-name'. +This should be used if your SSL program needs command line switches to +specify any behaviour (certificate file locations, etc). +The special symbols 'host and 'port may be used in the list of arguments +and will be replaced with the hostname and service/port that will be connected +to." + :group 'ssl + :type 'list) + +(defcustom ssl-view-certificate-program-name ssl-program-name + "*The program to run to provide a human-readable view of a certificate." + :group 'ssl + :type 'string) + +(defcustom ssl-view-certificate-program-arguments + '("x509" "-text" "-inform" "DER") + "*Arguments that should be passed to the certificate viewing program. +The certificate is piped to it. +Maybe a way of passing a file should be implemented." + :group 'ssl + :type 'list) + +(defun ssl-certificate-information (der) + "Return an assoc list of information about a certificate in DER format." + (let ((certificate (concat "-----BEGIN CERTIFICATE-----\n" + (base64-encode-string der) + "\n-----END CERTIFICATE-----\n")) + (exit-code 0)) + (save-excursion + (set-buffer (get-buffer-create " *openssl*")) + (erase-buffer) + (insert certificate) + (setq exit-code + (condition-case () + (call-process-region (point-min) (point-max) + ssl-program-name + t (list (current-buffer) nil) t + "x509" + "-subject" ; Print the subject DN + "-issuer" ; Print the issuer DN + "-dates" ; Both before and after dates + "-serial" ; print out serial number + "-noout" ; Don't spit out the certificate + ) + (error -1))) + (if (/= exit-code 0) + nil + (let ((vals nil)) + (goto-char (point-min)) + (while (re-search-forward "^\\([^=\n\r]+\\)\\s *=\\s *\\(.*\\)" nil t) + (push (cons (match-string 1) (match-string 2)) vals)) + vals))))) + +(defun ssl-accept-ca-certificate () + "Ask if the user is willing to accept a new CA certificate. +The buffer name should be the intended name of the certificate, and +the buffer should probably be in DER encoding" + ;; TODO, check if it is really new or if we already know it + (let* ((process-connection-type nil) + (tmpbuf (generate-new-buffer "X509 CA Certificate Information")) + (response (save-excursion + (and (eq 0 + (apply 'call-process-region + (point-min) (point-max) + ssl-view-certificate-program-name + nil tmpbuf t + ssl-view-certificate-program-arguments)) + (switch-to-buffer tmpbuf) + (goto-char (point-min)) + (or (recenter) t) + (yes-or-no-p + "Accept this CA to vouch for secure server identities? ") + (kill-buffer tmpbuf))))) + (if (not response) + nil + (if (not (file-directory-p ssl-certificate-directory)) + (make-directory ssl-certificate-directory)) + (case ssl-certificate-directory-style + (ssleay + (base64-encode-region (point-min) (point-max)) + (goto-char (point-min)) + (insert "-----BEGIN CERTIFICATE-----\n") + (goto-char (point-max)) + (insert "-----END CERTIFICATE-----\n") + (let ((f (expand-file-name + (concat (file-name-sans-extension (buffer-name)) ".pem") + ssl-certificate-directory))) + (write-file f) + (call-process ssl-rehash-program-name + nil nil nil + (expand-file-name ssl-certificate-directory)))))))) + +(defvar ssl-exec-wrapper nil) + +(defun ssl-get-command () + (if (memq system-type '(ms-dos ms-windows axp-vms vax-vms)) + ;; Nothing to do on DOS, Windows, or VMS! + (cons ssl-program-name ssl-program-arguments) + (if (not ssl-exec-wrapper) + (let ((script + (expand-file-name "exec_ssl_quietly" url-configuration-directory))) + (if (not (file-executable-p script)) + ;; Need to create our handy-dandy utility script to shut OpenSSL + ;; up completely. + (progn + (write-region "#!/bin/sh\n\nexec \"$@\" 2> /dev/null\n" nil + script nil 5) + (set-file-modes script 493))) ; (rwxr-xr-x) + (setq ssl-exec-wrapper script))) + (cons ssl-exec-wrapper (cons ssl-program-name ssl-program-arguments)))) + +(defun open-ssl-stream (name buffer host service) + "Open a SSL connection for a service to a host. +Returns a subprocess-object to represent the connection. +Input and output work as for subprocesses; `delete-process' closes it. +Args are NAME BUFFER HOST SERVICE. +NAME is name for process. It is modified if necessary to make it unique. +BUFFER is the buffer (or buffer name) to associate with the process. +Process output goes at end of that buffer, unless you specify +an output stream or filter function to handle the output. +BUFFER may be also nil, meaning that this process is not associated +with any buffer. +Third arg is name of the host to connect to, or its IP address. +Fourth arg SERVICE is name of the service desired, or an integer +specifying a port number to connect to." + (if (integerp service) (setq service (int-to-string service))) + (let* ((process-connection-type nil) + (port service) + (proc (eval `(start-process name buffer ,@(ssl-get-command))))) + (process-kill-without-query proc) + proc)) + +(provide 'ssl) + +;; arch-tag: 659fae92-1c67-4055-939f-32153c2f5114 }